QPQ-AG/sophia
10
0
Fork 0
Code Issues 41 Pull Requests 5 Actions Packages Projects Releases 16 Wiki Activity

Compile variants

Browse Source
This commit is contained in:
Ulf Norell 2019-04-23 16:03:24 +02:00
parent ed60cd8ddc
commit 9ac5a36265
2 changed files with 239 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

224
src/aeso_ast_to_fcode.erl
View File

@ -30,6 +30,7 @@
| {bool, false | true} | {bool, false | true}
| nil | nil
| {var, var_name()} | {var, var_name()}
| {con, arities(), tag(), [fexpr()]}
| {tuple, [fexpr()]} | {tuple, [fexpr()]}
| {proj, fexpr(), integer()} | {proj, fexpr(), integer()}
| {set_proj, fexpr(), integer(), fexpr()} %% tuple, field, new_value | {set_proj, fexpr(), integer(), fexpr()} %% tuple, field, new_value
@ -47,6 +48,7 @@
| {int, integer()} | {int, integer()}
| nil | nil
| {'::', var_name(), var_name()} | {'::', var_name(), var_name()}
| {con, arities(), tag(), [var_name()]}
| {tuple, [var_name()]}. | {tuple, [var_name()]}.
-type ftype() :: integer -type ftype() :: integer
@ -77,8 +79,15 @@
-type type_def() :: fun(([ftype()]) -> ftype()). -type type_def() :: fun(([ftype()]) -> ftype()).
-type tag() :: non_neg_integer().
-type arities() :: [non_neg_integer()].
-record(con_tag, { tag :: tag(), arities :: arities() }).
-type con_tag() :: #con_tag{}.
-type type_env() :: #{ sophia_name() => type_def() }. -type type_env() :: #{ sophia_name() => type_def() }.
-type fun_env() :: #{ sophia_name() => fun_name() }. -type fun_env() :: #{ sophia_name() => fun_name() }.
-type con_env() :: #{ sophia_name() => con_tag() }.
-type context() :: {main_contract, string()} -type context() :: {main_contract, string()}
| {namespace, string()} | {namespace, string()}
@ -86,6 +95,7 @@
-type env() :: #{ type_env := type_env(), -type env() :: #{ type_env := type_env(),
fun_env := fun_env(), fun_env := fun_env(),
con_env := con_env(),
options := [option()], options := [option()],
context => context(), context => context(),
functions := #{ fun_name() => fun_def() } }. functions := #{ fun_name() => fun_def() } }.
@ -104,6 +114,9 @@ ast_to_fcode(Code, Options) ->
init_env(Options) -> init_env(Options) ->
#{ type_env => init_type_env(), #{ type_env => init_type_env(),
fun_env => #{}, %% TODO: builtin functions here? fun_env => #{}, %% TODO: builtin functions here?
con_env => #{["None"] => #con_tag{ tag = 0, arities = [0, 1] },
["Some"] => #con_tag{ tag = 1, arities = [0, 1] }
},
options => Options, options => Options,
functions => #{} }. functions => #{} }.
@ -181,24 +194,53 @@ decl_to_fcode(Env = #{ functions := Funs }, {letfun, Ann, {id, _, Name}, Args, R
typedef_to_fcode(Env, {id, _, Name}, Xs, Def) -> typedef_to_fcode(Env, {id, _, Name}, Xs, Def) ->
Q = qname(Env, Name), Q = qname(Env, Name),
FDef = fun(Args) -> FDef = fun(Args) ->
Sub = maps:from_list(lists:zip([X || {tvar, _, X} <- Xs], Args)),
case Def of case Def of
{record_t, Fields} -> {todo, Xs, Args, record_t, Fields}; {record_t, Fields} -> {todo, Xs, Args, record_t, Fields};
{variant_t, Cons} -> {todo, Xs, Args, variant_t, Cons}; {variant_t, Cons} ->
{alias_t, Type} -> {todo, Xs, Args, alias_t, Type} FCons = [ begin
{constr_t, _, _, Ts} = Con,
[type_to_fcode(Env, Sub, T) || T <- Ts]
end || Con <- Cons ],
{variant, FCons};
{alias_t, Type} -> {todo, Xs, Args, alias_t, Type}
end end, end end,
bind_type(Env, Q, FDef). Constructors =
case Def of
{variant_t, Cons} ->
Arities = [ begin
{constr_t, _, _, Args} = Con,
length(Args)
end || Con <- Cons ],
Tags = [ #con_tag{ tag = I, arities = Arities } || I <- lists:seq(0, length(Cons) - 1) ],
GetName = fun({constr_t, _, {con, _, C}, _}) -> C end,
QName = fun(Con) -> qname(Env, GetName(Con)) end,
maps:from_list([ {QName(Con), Tag} || {Tag, Con} <- lists:zip(Tags, Cons) ]);
_ -> #{}
end,
Env1 = bind_constructors(Env, Constructors),
bind_type(Env1, Q, FDef).
-spec type_to_fcode(env(), aeso_syntax:type()) -> ftype(). -spec type_to_fcode(env(), aeso_syntax:type()) -> ftype().
type_to_fcode(Env, {app_t, _, T = {Id, _, _}, Types}) when Id == id; Id == qid -> type_to_fcode(Env, Type) ->
lookup_type(Env, T, [type_to_fcode(Env, Type) || Type <- Types]); type_to_fcode(Env, #{}, Type).
type_to_fcode(Env, T = {Id, _, _}) when Id == id; Id == qid ->
-spec type_to_fcode(env(), #{var_name() => ftype()}, aeso_syntax:type()) -> ftype().
type_to_fcode(Env, Sub, {app_t, _, T = {Id, _, _}, Types}) when Id == id; Id == qid ->
lookup_type(Env, T, [type_to_fcode(Env, Sub, Type) || Type <- Types]);
type_to_fcode(Env, _Sub, T = {Id, _, _}) when Id == id; Id == qid ->
lookup_type(Env, T, []); lookup_type(Env, T, []);
type_to_fcode(Env, {tuple_t, _, Types}) -> type_to_fcode(Env, Sub, {tuple_t, _, Types}) ->
{tuple, [type_to_fcode(Env, T) || T <- Types]}; {tuple, [type_to_fcode(Env, Sub, T) || T <- Types]};
type_to_fcode(Env, {record_t, Fields}) -> type_to_fcode(Env, Sub, {record_t, Fields}) ->
FieldType = fun({field_t, _, _, Ty}) -> Ty end, FieldType = fun({field_t, _, _, Ty}) -> Ty end,
type_to_fcode(Env, {tuple_t, [], lists:map(FieldType, Fields)}); type_to_fcode(Env, Sub, {tuple_t, [], lists:map(FieldType, Fields)});
type_to_fcode(_Env, Type) -> type_to_fcode(_Env, Sub, {tvar, _, X} = Type) ->
case maps:get(X, Sub, not_found) of
not_found -> {todo, polymorphism, Type};
FType -> FType
end;
type_to_fcode(_Env, _Sub, Type) ->
error({todo, Type}). error({todo, Type}).
-spec args_to_fcode(env(), [aeso_syntax:arg()]) -> [{var_name(), ftype()}]. -spec args_to_fcode(env(), [aeso_syntax:arg()]) -> [{var_name(), ftype()}].
@ -220,6 +262,17 @@ expr_to_fcode(_Env, _Type, {bool, _, B}) -> {bool, B};
%% Variables %% Variables
expr_to_fcode(_Env, _Type, {id, _, X}) -> {var, X}; expr_to_fcode(_Env, _Type, {id, _, X}) -> {var, X};
%% Constructors
expr_to_fcode(Env, Type, {C, _, _} = Con) when C == con; C == qcon ->
expr_to_fcode(Env, Type, {app, [], {typed, [], Con, Type}, []});
expr_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Args}) when C == con; C == qcon ->
#con_tag{ tag = I, arities = Arities } = lookup_con(Env, Con),
Arity = lists:nth(I + 1, Arities),
case length(Args) == Arity of
true -> {con, Arities, I, [expr_to_fcode(Env, Arg) || Arg <- Args]};
false -> fcode_error({constructor_arity_mismatch, Con, length(Args), Arity})
end;
%% Tuples %% Tuples
expr_to_fcode(Env, _Type, {tuple, _, Es}) -> expr_to_fcode(Env, _Type, {tuple, _, Es}) ->
{tuple, [expr_to_fcode(Env, E) || E <- Es]}; {tuple, [expr_to_fcode(Env, E) || E <- Es]};
@ -312,7 +365,8 @@ alts_to_fcode(Env, Type, X, Alts) ->
| {bool, false | true} | {bool, false | true}
| {int, integer()} | {int, integer()}
| nil | {'::', fpat(), fpat()} | nil | {'::', fpat(), fpat()}
| {tuple, [fpat()]}. | {tuple, [fpat()]}
| {con, arities(), tag(), [fpat()]}.
%% %% Invariant: the number of variables matches the number of patterns in each falt. %% %% Invariant: the number of variables matches the number of patterns in each falt.
-spec split_tree(env(), [{var_name(), ftype()}], [falt()]) -> fsplit(). -spec split_tree(env(), [{var_name(), ftype()}], [falt()]) -> fsplit().
@ -346,15 +400,17 @@ merge_alts(I, X, Alts, Alts1) ->
when Alts :: [{fsplit_pat(), [falt()]}]. when Alts :: [{fsplit_pat(), [falt()]}].
merge_alt(_, _, {P, A}, []) -> [{P, [A]}]; merge_alt(_, _, {P, A}, []) -> [{P, [A]}];
merge_alt(I, X, {P, A}, [{Q, As} | Rest]) -> merge_alt(I, X, {P, A}, [{Q, As} | Rest]) ->
Match = fun({var, _}, {var, _}) -> match; Match = fun({var, _}, {var, _}) -> match;
({tuple, _}, {tuple, _}) -> match; ({tuple, _}, {tuple, _}) -> match;
({bool, B}, {bool, B}) -> match; ({bool, B}, {bool, B}) -> match;
({int, N}, {int, N}) -> match; ({int, N}, {int, N}) -> match;
(nil, nil) -> match; (nil, nil) -> match;
({'::', _, _}, {'::', _, _}) -> match; ({'::', _, _}, {'::', _, _}) -> match;
({var, _}, _) -> expand; ({con, _, C, _}, {con, _, C, _}) -> match;
(_, {var, _}) -> insert; ({con, _, _, _}, {con, _, _, _}) -> mismatch;
(_, _) -> mismatch ({var, _}, _) -> expand;
(_, {var, _}) -> insert;
(_, _) -> mismatch
end, end,
case Match(P, Q) of case Match(P, Q) of
match -> [{Q, [A | As]} | Rest]; match -> [{Q, [A | As]} | Rest];
@ -367,21 +423,25 @@ merge_alt(I, X, {P, A}, [{Q, As} | Rest]) ->
expand(I, X, P, Q, Case = {'case', Ps, E}) -> expand(I, X, P, Q, Case = {'case', Ps, E}) ->
{Ps0, [{var, Y} | Ps1]} = lists:split(I - 1, Ps), {Ps0, [{var, Y} | Ps1]} = lists:split(I - 1, Ps),
{Ps0r, Ren1} = rename_pats([{Y, X} || Y /= X], Ps0), {Ps0r, Ren1} = rename_fpats([{Y, X} || Y /= X], Ps0),
{Ps1r, Ren2} = rename_pats(Ren1, Ps1), {Ps1r, Ren2} = rename_fpats(Ren1, Ps1),
E1 = rename(Ren2, E), E1 = rename(Ren2, E),
Splice = fun(N) -> Ps0r ++ lists:duplicate(N, {var, "_"}) ++ Ps1r end, Splice = fun(N) -> Ps0r ++ lists:duplicate(N, {var, "_"}) ++ Ps1r end,
Type = fun({tuple, Xs}) -> {tuple, length(Xs)}; Type = fun({tuple, Xs}) -> {tuple, length(Xs)};
({bool, _}) -> bool; ({bool, _}) -> bool;
({int, _}) -> int; ({int, _}) -> int;
(nil) -> list; (nil) -> list;
({'::', _, _}) -> list end, ({'::', _, _}) -> list;
({con, As, _, _}) -> {variant, As}
end,
MkCase = fun(Pat, Vars) -> {Pat, {'case', Splice(Vars), E1}} end, MkCase = fun(Pat, Vars) -> {Pat, {'case', Splice(Vars), E1}} end,
case Type(Q) of case Type(Q) of
{tuple, N} -> {[MkCase(Q, N)], []}; {tuple, N} -> {[MkCase(Q, N)], []};
bool -> {[MkCase({bool, B}, 0) || B <- [false, true]], []}; bool -> {[MkCase({bool, B}, 0) || B <- [false, true]], []};
int -> {[MkCase(Q, 0)], [{P, Case}]}; int -> {[MkCase(Q, 0)], [{P, Case}]};
list -> {[MkCase(nil, 0), MkCase({'::', fresh_name(), fresh_name()}, 2)], []} list -> {[MkCase(nil, 0), MkCase({'::', fresh_name(), fresh_name()}, 2)], []};
{variant, As} -> {[MkCase({con, As, C - 1, [fresh_name() || _ <- lists:seq(1, Ar)]}, Ar)
|| {C, Ar} <- indexed(As)], []}
end. end.
-spec split_alt(integer(), falt()) -> {fsplit_pat(), falt()}. -spec split_alt(integer(), falt()) -> {fsplit_pat(), falt()}.
@ -396,6 +456,9 @@ split_pat({bool, B}) -> {{bool, B}, []};
split_pat({int, N}) -> {{int, N}, []}; split_pat({int, N}) -> {{int, N}, []};
split_pat(nil) -> {nil, []}; split_pat(nil) -> {nil, []};
split_pat({'::', P, Q}) -> {{'::', fresh_name(), fresh_name()}, [P, Q]}; split_pat({'::', P, Q}) -> {{'::', fresh_name(), fresh_name()}, [P, Q]};
split_pat({con, As, I, Pats}) ->
Xs = [fresh_name() || _ <- Pats],
{{con, As, I, Xs}, Pats};
split_pat({tuple, Pats}) -> split_pat({tuple, Pats}) ->
Xs = [fresh_name() || _ <- Pats], Xs = [fresh_name() || _ <- Pats],
{{tuple, Xs}, Pats}. {{tuple, Xs}, Pats}.
@ -405,6 +468,8 @@ split_vars({bool, _}, boolean) -> [];
split_vars({int, _}, integer) -> []; split_vars({int, _}, integer) -> [];
split_vars(nil, {list, _}) -> []; split_vars(nil, {list, _}) -> [];
split_vars({'::', X, Xs}, {list, T}) -> [{X, T}, {Xs, {list, T}}]; split_vars({'::', X, Xs}, {list, T}) -> [{X, T}, {Xs, {list, T}}];
split_vars({con, _, I, Xs}, {variant, Cons}) ->
lists:zip(Xs, lists:nth(I + 1, Cons));
split_vars({tuple, Xs}, {tuple, Ts}) -> split_vars({tuple, Xs}, {tuple, Ts}) ->
lists:zip(Xs, Ts); lists:zip(Xs, Ts);
split_vars({var, X}, T) -> [{X, T}]. split_vars({var, X}, T) -> [{X, T}].
@ -416,6 +481,7 @@ rename(Ren, Expr) ->
{bool, _} -> Expr; {bool, _} -> Expr;
nil -> nil; nil -> nil;
{var, X} -> {var, rename_var(Ren, X)}; {var, X} -> {var, rename_var(Ren, X)};
{con, Ar, I, Es} -> {con, Ar, I, [rename(Ren, E) || E <- Es]};
{tuple, Es} -> {tuple, [rename(Ren, E) || E <- Es]}; {tuple, Es} -> {tuple, [rename(Ren, E) || E <- Es]};
{proj, E, I} -> {proj, rename(Ren, E), I}; {proj, E, I} -> {proj, rename(Ren, E), I};
{set_proj, R, I, E} -> {set_proj, rename(Ren, R), I, rename(Ren, E)}; {set_proj, R, I, E} -> {set_proj, rename(Ren, R), I, rename(Ren, E)};
@ -442,23 +508,43 @@ rename_bindings(Ren, [X | Xs]) ->
{Zs, Ren2} = rename_bindings(Ren1, Xs), {Zs, Ren2} = rename_bindings(Ren1, Xs),
{[Z | Zs], Ren2}. {[Z | Zs], Ren2}.
rename_pats(Ren, []) -> {[], Ren}; rename_fpats(Ren, []) -> {[], Ren};
rename_pats(Ren, [P | Ps]) -> rename_fpats(Ren, [P | Ps]) ->
{Q, Ren1} = rename_pat(Ren, P), {Q, Ren1} = rename_fpat(Ren, P),
{Qs, Ren2} = rename_pats(Ren1, Ps), {Qs, Ren2} = rename_fpats(Ren1, Ps),
{[Q | Qs], Ren2}. {[Q | Qs], Ren2}.
rename_pat(Ren, P = {bool, _}) -> {P, Ren}; rename_fpat(Ren, P = {bool, _}) -> {P, Ren};
rename_pat(Ren, P = {int, _}) -> {P, Ren}; rename_fpat(Ren, P = {int, _}) -> {P, Ren};
rename_pat(Ren, P = nil) -> {P, Ren}; rename_fpat(Ren, P = nil) -> {P, Ren};
rename_pat(Ren, {'::', P, Q}) -> rename_fpat(Ren, {'::', P, Q}) ->
{P1, Ren1} = rename_pat(Ren, P), {P1, Ren1} = rename_fpat(Ren, P),
{Q1, Ren2} = rename_pat(Ren1, Q), {Q1, Ren2} = rename_fpat(Ren1, Q),
{{'::', P1, Q1}, Ren2}; {{'::', P1, Q1}, Ren2};
rename_pat(Ren, {var, X}) -> rename_fpat(Ren, {var, X}) ->
{Z, Ren1} = rename_binding(Ren, X), {Z, Ren1} = rename_binding(Ren, X),
{{var, Z}, Ren1}; {{var, Z}, Ren1};
rename_pat(Ren, {tuple, Xs}) -> rename_fpat(Ren, {con, Ar, C, Ps}) ->
{Ps1, Ren1} = rename_fpats(Ren, Ps),
{{con, Ar, C, Ps1}, Ren1};
rename_fpat(Ren, {tuple, Ps}) ->
{Ps1, Ren1} = rename_fpats(Ren, Ps),
{{tuple, Ps1}, Ren1}.
rename_spat(Ren, P = {bool, _}) -> {P, Ren};
rename_spat(Ren, P = {int, _}) -> {P, Ren};
rename_spat(Ren, P = nil) -> {P, Ren};
rename_spat(Ren, {'::', X, Y}) ->
{X1, Ren1} = rename_binding(Ren, X),
{Y1, Ren2} = rename_binding(Ren1, Y),
{{'::', X1, Y1}, Ren2};
rename_spat(Ren, {var, X}) ->
{Z, Ren1} = rename_binding(Ren, X),
{{var, Z}, Ren1};
rename_spat(Ren, {con, Ar, C, Xs}) ->
{Zs, Ren1} = rename_bindings(Ren, Xs),
{{con, Ar, C, Zs}, Ren1};
rename_spat(Ren, {tuple, Xs}) ->
{Zs, Ren1} = rename_bindings(Ren, Xs), {Zs, Ren1} = rename_bindings(Ren, Xs),
{{tuple, Zs}, Ren1}. {{tuple, Zs}, Ren1}.
@ -467,7 +553,7 @@ rename_split(Ren, {split, Type, X, Cases}) ->
rename_split(Ren, {nosplit, E}) -> {nosplit, rename(Ren, E)}. rename_split(Ren, {nosplit, E}) -> {nosplit, rename(Ren, E)}.
rename_case(Ren, {'case', Pat, Split}) -> rename_case(Ren, {'case', Pat, Split}) ->
{Pat1, Ren1} = rename_pat(Ren, Pat), {Pat1, Ren1} = rename_spat(Ren, Pat),
{'case', Pat1, rename_split(Ren1, Split)}. {'case', Pat1, rename_split(Ren1, Split)}.
-spec next_split([fpat()]) -> integer() | false. -spec next_split([fpat()]) -> integer() | false.
@ -490,6 +576,11 @@ pat_to_fcode(Env, Pat) ->
-spec pat_to_fcode(env(), aeso_syntax:type() | no_type, aeso_syntax:pat()) -> fpat(). -spec pat_to_fcode(env(), aeso_syntax:type() | no_type, aeso_syntax:pat()) -> fpat().
pat_to_fcode(_Env, _Type, {id, _, X}) -> {var, X}; pat_to_fcode(_Env, _Type, {id, _, X}) -> {var, X};
pat_to_fcode(Env, Type, {C, _, _} = Con) when C == con; C == qcon ->
pat_to_fcode(Env, Type, {app, [], {typed, [], Con, Type}, []});
pat_to_fcode(Env, _Type, {app, _, {typed, _, {C, _, _} = Con, _}, Pats}) when C == con; C == qcon ->
#con_tag{tag = I, arities = As} = lookup_con(Env, Con),
{con, As, I, [pat_to_fcode(Env, Pat) || Pat <- Pats]};
pat_to_fcode(Env, _Type, {tuple, _, Pats}) -> pat_to_fcode(Env, _Type, {tuple, _, Pats}) ->
{tuple, [ pat_to_fcode(Env, Pat) || Pat <- Pats ]}; {tuple, [ pat_to_fcode(Env, Pat) || Pat <- Pats ]};
pat_to_fcode(_Env, _Type, {bool, _, B}) -> pat_to_fcode(_Env, _Type, {bool, _, B}) ->
@ -557,6 +648,10 @@ lookup_type(#{ type_env := TypeEnv }, Name, Args, Default) ->
bind_type(Env = #{type_env := TEnv}, Q, FDef) -> bind_type(Env = #{type_env := TEnv}, Q, FDef) ->
Env#{ type_env := TEnv#{ Q => FDef } }. Env#{ type_env := TEnv#{ Q => FDef } }.
-spec bind_constructors(env(), con_env()) -> env().
bind_constructors(Env = #{ con_env := ConEnv }, NewCons) ->
Env#{ con_env := maps:merge(ConEnv, NewCons) }.
%% -- Names -- %% -- Names --
-spec add_fun_env(env(), [aeso_syntax:decl()]) -> env(). -spec add_fun_env(env(), [aeso_syntax:decl()]) -> env().
@ -600,6 +695,15 @@ lookup_fun(#{ fun_env := FunEnv }, Name) ->
FName -> FName FName -> FName
end. end.
-spec lookup_con(env(), aeso_syntax:con() | aeso_syntax:qcon() | sophia_name()) -> con_tag().
lookup_con(Env, {con, _, Con}) -> lookup_con(Env, [Con]);
lookup_con(Env, {qcon, _, Con}) -> lookup_con(Env, Con);
lookup_con(#{ con_env := ConEnv }, Con) ->
case maps:get(Con, ConEnv, false) of
false -> error({unbound_constructor, Con});
Tag -> Tag
end.
init_fresh_names() -> init_fresh_names() ->
put('%fresh', 0). put('%fresh', 0).
@ -640,6 +744,9 @@ get_attributes(Ann) ->
indexed(Xs) -> indexed(Xs) ->
lists:zip(lists:seq(1, length(Xs)), Xs). lists:zip(lists:seq(1, length(Xs)), Xs).
fcode_error(Err) ->
error(Err).
%% -- Pretty printing -------------------------------------------------------- %% -- Pretty printing --------------------------------------------------------
format_fexpr(E) -> format_fexpr(E) ->
@ -659,8 +766,8 @@ pp_above([X | Xs]) -> pp_above(X, pp_above(Xs)).
pp_above(A, B) -> prettypr:above(A, B). pp_above(A, B) -> prettypr:above(A, B).
pp_parens(Doc) -> pp_parens(Doc) -> pp_beside([pp_text("("), Doc, pp_text(")")]).
pp_beside([pp_text("("), Doc, pp_text(")")]). pp_braces(Doc) -> pp_beside([pp_text("{"), Doc, pp_text("}")]).
pp_punctuate(_Sep, []) -> []; pp_punctuate(_Sep, []) -> [];
pp_punctuate(_Sep, [X]) -> [X]; pp_punctuate(_Sep, [X]) -> [X];
@ -674,10 +781,17 @@ pp_fexpr(nil) ->
pp_text("[]"); pp_text("[]");
pp_fexpr({var, X}) -> pp_fexpr({var, X}) ->
pp_text(X); pp_text(X);
pp_fexpr({con, _, I, []}) ->
pp_beside(pp_text("C"), pp_text(I));
pp_fexpr({con, _, I, Es}) ->
pp_beside(pp_fexpr({con, [], I, []}),
pp_fexpr({tuple, Es}));
pp_fexpr({tuple, Es}) -> pp_fexpr({tuple, Es}) ->
pp_parens(prettypr:par(pp_punctuate(pp_text(","), [pp_fexpr(E) || E <- Es]))); pp_parens(prettypr:par(pp_punctuate(pp_text(","), [pp_fexpr(E) || E <- Es])));
pp_fexpr({proj, E, I}) -> pp_fexpr({proj, E, I}) ->
pp_beside([pp_fexpr(E), pp_text("."), pp_text(I)]); pp_beside([pp_fexpr(E), pp_text("."), pp_text(I)]);
pp_fexpr({set_proj, E, I, A}) ->
pp_beside(pp_fexpr(E), pp_braces(pp_beside([pp_text(I), pp_text(" = "), pp_fexpr(A)])));
pp_fexpr({binop, Op, A, B}) -> pp_fexpr({binop, Op, A, B}) ->
pp_parens(prettypr:par([pp_fexpr(A), pp_text(Op), pp_fexpr(B)])); pp_parens(prettypr:par([pp_fexpr(A), pp_text(Op), pp_fexpr(B)]));
pp_fexpr({'let', X, A, B}) -> pp_fexpr({'let', X, A, B}) ->
@ -689,7 +803,14 @@ pp_ftype(T) when is_atom(T) -> pp_text(T);
pp_ftype({tuple, Ts}) -> pp_ftype({tuple, Ts}) ->
pp_parens(prettypr:par(pp_punctuate(pp_text(","), [pp_ftype(T) || T <- Ts]))); pp_parens(prettypr:par(pp_punctuate(pp_text(","), [pp_ftype(T) || T <- Ts])));
pp_ftype({list, T}) -> pp_ftype({list, T}) ->
pp_beside([pp_text("list("), pp_ftype(T), pp_text(")")]). pp_beside([pp_text("list("), pp_ftype(T), pp_text(")")]);
pp_ftype({variant, Cons}) ->
prettypr:par(
pp_punctuate(pp_text(" |"),
[ case Args of
[] -> pp_fexpr({con, [], I - 1, []});
_ -> pp_beside(pp_fexpr({con, [], I - 1, []}), pp_ftype({tuple, Args}))
end || {I, Args} <- indexed(Cons)])).
pp_split({nosplit, E}) -> pp_fexpr(E); pp_split({nosplit, E}) -> pp_fexpr(E);
pp_split({split, Type, X, Alts}) -> pp_split({split, Type, X, Alts}) ->
@ -700,7 +821,8 @@ pp_case({'case', Pat, Split}) ->
prettypr:sep([pp_beside(pp_pat(Pat), pp_text(" =>")), prettypr:sep([pp_beside(pp_pat(Pat), pp_text(" =>")),
prettypr:nest(2, pp_split(Split))]). prettypr:nest(2, pp_split(Split))]).
pp_pat({tuple, Xs}) -> pp_fexpr({tuple, [{var, X} || X <- Xs]}); pp_pat({tuple, Xs}) -> pp_fexpr({tuple, [{var, X} || X <- Xs]});
pp_pat({'::', X, Xs}) -> pp_fexpr({binop, '::', {var, X}, {var, Xs}}); pp_pat({'::', X, Xs}) -> pp_fexpr({binop, '::', {var, X}, {var, Xs}});
pp_pat(Pat) -> pp_fexpr(Pat). pp_pat({con, As, I, Xs}) -> pp_fexpr({con, As, I, [{var, X} || X <- Xs]});
pp_pat(Pat) -> pp_fexpr(Pat).

88
src/aeso_fcode_to_fate.erl
View File

@ -28,7 +28,7 @@
-type var() :: {var, integer()}. -type var() :: {var, integer()}.
-type vars() :: ordsets:ordset(var()). -type vars() :: ordsets:ordset(var()).
-type stype() :: tuple | boolean. -type stype() :: tuple | boolean | {variant, [non_neg_integer()]}.
-type maybe_scode() :: missing | scode(). -type maybe_scode() :: missing | scode().
-type maybe_scode_a() :: missing | scode_a(). -type maybe_scode_a() :: missing | scode_a().
@ -53,6 +53,7 @@
Op =:= 'AND' orelse Op =:= 'AND' orelse
Op =:= 'OR' orelse Op =:= 'OR' orelse
Op =:= 'ELEMENT' orelse Op =:= 'ELEMENT' orelse
Op =:= 'VARIANT_ELEMENT' orelse
Op =:= 'CONS')). Op =:= 'CONS')).
-define(IsUnOp(Op), -define(IsUnOp(Op),
@ -100,10 +101,16 @@ functions_to_scode(Functions, Options) ->
function_to_scode(Name, Args, Body, ResType, Options) -> function_to_scode(Name, Args, Body, ResType, Options) ->
debug(scode, Options, "Compiling ~p ~p : ~p ->\n ~p\n", [Name, Args, ResType, Body]), debug(scode, Options, "Compiling ~p ~p : ~p ->\n ~p\n", [Name, Args, ResType, Body]),
ArgTypes = [ T || {_, T} <- Args ], ArgTypes = [ type_to_scode(T) || {_, T} <- Args ],
SCode = to_scode(init_env(Args), Body), SCode = to_scode(init_env(Args), Body),
debug(scode, Options, " scode: ~p\n", [SCode]), debug(scode, Options, " scode: ~p\n", [SCode]),
{{ArgTypes, ResType}, SCode}. {{ArgTypes, type_to_scode(ResType)}, SCode}.
type_to_scode({variant, Cons}) -> {variant, lists:map(fun length/1, Cons)};
type_to_scode({list, Type}) -> {list, type_to_scode(Type)};
type_to_scode({tuple, Types}) -> {tuple, lists:map(fun type_to_scode/1, Types)};
type_to_scode({map, Key, Val}) -> {map, type_to_scode(Key), type_to_scode(Val)};
type_to_scode(T) -> T.
%% -- Phase I ---------------------------------------------------------------- %% -- Phase I ----------------------------------------------------------------
%% Icode to structured assembly %% Icode to structured assembly
@ -145,6 +152,11 @@ to_scode(_Env, nil) -> aeb_fate_code:nil(?a);
to_scode(Env, {var, X}) -> to_scode(Env, {var, X}) ->
[aeb_fate_code:push(lookup_var(Env, X))]; [aeb_fate_code:push(lookup_var(Env, X))];
to_scode(Env, {con, Ar, I, As}) ->
N = length(As),
[[to_scode(Env, A) || A <- As],
aeb_fate_code:variant(?a, ?i(Ar), ?i(I), ?i(N))];
to_scode(Env, {tuple, As}) -> to_scode(Env, {tuple, As}) ->
N = length(As), N = length(As),
[[ to_scode(Env, A) || A <- As ], [[ to_scode(Env, A) || A <- As ],
@ -182,13 +194,14 @@ split_to_scode(Env, {nosplit, Expr}) ->
[switch_body, to_scode(Env, Expr)]; [switch_body, to_scode(Env, Expr)];
split_to_scode(Env, {split, {tuple, _}, X, Alts}) -> split_to_scode(Env, {split, {tuple, _}, X, Alts}) ->
{Def, Alts1} = catchall_to_scode(Env, X, Alts), {Def, Alts1} = catchall_to_scode(Env, X, Alts),
Arg = lookup_var(Env, X),
Alt = case [ {Xs, Split} || {'case', {tuple, Xs}, Split} <- Alts1 ] of Alt = case [ {Xs, Split} || {'case', {tuple, Xs}, Split} <- Alts1 ] of
[] -> missing; [] -> missing;
[{Xs, S} | _] -> [{Xs, S} | _] ->
{Code, Env1} = match_tuple(Env, Xs), {Code, Env1} = match_tuple(Env, Arg, Xs),
[Code, split_to_scode(Env1, S)] [Code, split_to_scode(Env1, S)]
end, end,
[aeb_fate_code:push(lookup_var(Env, X)), [aeb_fate_code:push(Arg),
case Def == missing andalso Alt /= missing of case Def == missing andalso Alt /= missing of
true -> Alt; % skip the switch if single tuple pattern true -> Alt; % skip the switch if single tuple pattern
false -> {switch, tuple, [Alt], Def} false -> {switch, tuple, [Alt], Def}
@ -225,6 +238,20 @@ split_to_scode(Env, {split, {list, _}, X, Alts}) ->
split_to_scode(Env, {split, integer, X, Alts}) -> split_to_scode(Env, {split, integer, X, Alts}) ->
{Def, Alts1} = catchall_to_scode(Env, X, Alts), {Def, Alts1} = catchall_to_scode(Env, X, Alts),
literal_split_to_scode(Env, integer, X, Alts1, Def); literal_split_to_scode(Env, integer, X, Alts1, Def);
split_to_scode(Env, {split, {variant, Cons}, X, Alts}) ->
{Def, Alts1} = catchall_to_scode(Env, X, Alts),
Arg = lookup_var(Env, X),
GetAlt = fun(I) ->
case [{Xs, S} || {'case', {con, _, J, Xs}, S} <- Alts1, I == J] of
[] -> missing;
[{Xs, S} | _] ->
{Code, Env1} = match_variant(Env, Arg, Xs),
[Code, split_to_scode(Env1, S)]
end
end,
SType = {variant, [length(Args) || Args <- Cons]},
[aeb_fate_code:push(Arg),
{switch, SType, [GetAlt(I) || I <- lists:seq(0, length(Cons) - 1)], Def}];
split_to_scode(_, Split = {split, _, _, _}) -> split_to_scode(_, Split = {split, _, _, _}) ->
?TODO({'case', Split}). ?TODO({'case', Split}).
@ -250,18 +277,20 @@ catchall_to_scode(Env, X, [Alt | Alts], Acc) ->
catchall_to_scode(_, _, [], Acc) -> {missing, lists:reverse(Acc)}. catchall_to_scode(_, _, [], Acc) -> {missing, lists:reverse(Acc)}.
%% Tuple is in the accumulator. Arguments are the variable names. %% Tuple is in the accumulator. Arguments are the variable names.
match_tuple(Env, Xs) -> match_tuple(Env, Arg, Xs) ->
match_tuple(Env, 0, Xs). match_tuple(Env, 0, fun aeb_fate_code:element_op/3, Arg, Xs).
match_tuple(Env, I, ["_" | Xs]) -> match_variant(Env, Arg, Xs) ->
match_tuple(Env, I + 1, Xs); Elem = fun(Dst, I, Val) -> aeb_fate_code:variant_element(Dst, Val, I) end,
match_tuple(Env, I, [X | Xs]) -> match_tuple(Env, 0, Elem, Arg, Xs).
match_tuple(Env, I, Elem, Arg, ["_" | Xs]) ->
match_tuple(Env, I + 1, Elem, Arg, Xs);
match_tuple(Env, I, Elem, Arg, [X | Xs]) ->
{J, Env1} = bind_local(X, Env), {J, Env1} = bind_local(X, Env),
{Code, Env2} = match_tuple(Env1, I + 1, Xs), {Code, Env2} = match_tuple(Env1, I + 1, Elem, Arg, Xs),
{[ [aeb_fate_code:dup() || [] /= [Y || Y <- Xs, Y /= "_"]], %% Don't DUP the last one {[Elem({var, J}, ?i(I), Arg), Code], Env2};
aeb_fate_code:element_op({var, J}, ?i(I), ?a), match_tuple(Env, _, _, _, []) ->
Code], Env2};
match_tuple(Env, _, []) ->
{[], Env}. {[], Env}.
%% -- Operators -- %% -- Operators --
@ -315,8 +344,9 @@ simpl_loop(N, Code, Options) ->
pp_ann(Ind, [{switch, Type, Alts, Def} | Code]) -> pp_ann(Ind, [{switch, Type, Alts, Def} | Code]) ->
Tags = Tags =
case Type of case Type of
boolean -> ["FALSE", "TRUE"]; boolean -> ["FALSE", "TRUE"];
tuple -> ["(_)"] tuple -> ["(_)"];
{variant, Ar} -> ["C" ++ integer_to_list(I) || I <- lists:seq(0, length(Ar) - 1)]
end, end,
[[[Ind, Tag, " =>\n", pp_ann(" " ++ Ind, Alt)] [[[Ind, Tag, " =>\n", pp_ann(" " ++ Ind, Alt)]
|| {Tag, Alt} <- lists:zip(Tags, Alts), Alt /= missing], || {Tag, Alt} <- lists:zip(Tags, Alts), Alt /= missing],
@ -851,7 +881,13 @@ block(Blk = #blk{code = [{switch, Type, Alts, Default} | Code],
{Blk#blk{code = ElseCode}, [{jumpif, ThenRef}], ThenBlk}; {Blk#blk{code = ElseCode}, [{jumpif, ThenRef}], ThenBlk};
tuple -> tuple ->
[TCode] = Alts, [TCode] = Alts,
{Blk#blk{code = TCode ++ [{jump, RestRef}]}, [], []} {Blk#blk{code = TCode ++ [{jump, RestRef}]}, [], []};
{variant, _Ar} ->
MkBlk = fun(missing) -> {DefRef, []};
(ACode) -> FreshBlk(ACode ++ [{jump, RestRef}], DefRef)
end,
{AltRefs, AltBs} = lists:unzip(lists:map(MkBlk, Alts)),
{Blk#blk{code = []}, [{switch, AltRefs}], lists:append(AltBs)}
end, end,
Blk2 = Blk1#blk{catchall = DefRef}, %% Update catchall ref Blk2 = Blk1#blk{catchall = DefRef}, %% Update catchall ref
block(Blk2, Code1 ++ Acc, DefBlk ++ RestBlk ++ AltBlks ++ Blocks, BlockAcc); block(Blk2, Code1 ++ Acc, DefBlk ++ RestBlk ++ AltBlks ++ Blocks, BlockAcc);
@ -883,7 +919,8 @@ reorder_blocks(Ref, Code, Blocks, Acc) ->
['RETURN'|_] -> reorder_blocks(Blocks, Acc1); ['RETURN'|_] -> reorder_blocks(Blocks, Acc1);
[{'RETURNR', _}|_] -> reorder_blocks(Blocks, Acc1); [{'RETURNR', _}|_] -> reorder_blocks(Blocks, Acc1);
[{'ABORT', _}|_] -> reorder_blocks(Blocks, Acc1); [{'ABORT', _}|_] -> reorder_blocks(Blocks, Acc1);
[{jump, L}|_] -> [{switch, _}|_] -> reorder_blocks(Blocks, Acc1);
[{jump, L}|_] ->
NotL = fun({L1, _}) -> L1 /= L end, NotL = fun({L1, _}) -> L1 /= L end,
case lists:splitwith(NotL, Blocks) of case lists:splitwith(NotL, Blocks) of
{Blocks1, [{L, Code1} | Blocks2]} -> {Blocks1, [{L, Code1} | Blocks2]} ->
@ -911,9 +948,10 @@ remove_dead_blocks(Blocks = [{Top, _} | _]) ->
chase_labels([], _, Live) -> Live; chase_labels([], _, Live) -> Live;
chase_labels([L | Ls], Map, Live) -> chase_labels([L | Ls], Map, Live) ->
Code = maps:get(L, Map), Code = maps:get(L, Map),
Jump = fun({jump, A}) -> [A || not maps:is_key(A, Live)]; Jump = fun({jump, A}) -> [A || not maps:is_key(A, Live)];
({jumpif, A}) -> [A || not maps:is_key(A, Live)]; ({jumpif, A}) -> [A || not maps:is_key(A, Live)];
(_) -> [] end, ({switch, As}) -> [A || A <- As, not maps:is_key(A, Live)];
(_) -> [] end,
New = lists:flatmap(Jump, Code), New = lists:flatmap(Jump, Code),
chase_labels(New ++ Ls, Map, Live#{ L => true }). chase_labels(New ++ Ls, Map, Live#{ L => true }).
@ -928,6 +966,12 @@ set_labels(Labels, {Ref, Code}) when is_reference(Ref) ->
{maps:get(Ref, Labels), [ set_labels(Labels, I) || I <- Code ]}; {maps:get(Ref, Labels), [ set_labels(Labels, I) || I <- Code ]};
set_labels(Labels, {jump, Ref}) -> aeb_fate_code:jump(maps:get(Ref, Labels)); set_labels(Labels, {jump, Ref}) -> aeb_fate_code:jump(maps:get(Ref, Labels));
set_labels(Labels, {jumpif, Ref}) -> aeb_fate_code:jumpif(?a, maps:get(Ref, Labels)); set_labels(Labels, {jumpif, Ref}) -> aeb_fate_code:jumpif(?a, maps:get(Ref, Labels));
set_labels(Labels, {switch, Refs}) ->
case [ maps:get(Ref, Labels) || Ref <- Refs ] of
[R1, R2] -> aeb_fate_code:switch(?a, R1, R2);
[R1, R2, R3] -> aeb_fate_code:switch(?a, R1, R2, R3);
Rs -> aeb_fate_code:switch(?a, Rs)
end;
set_labels(_, I) -> I. set_labels(_, I) -> I.
%% -- Helpers ---------------------------------------------------------------- %% -- Helpers ----------------------------------------------------------------