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

184
src/aeso_ast_to_fcode.erl
View File

@ -30,6 +30,7 @@
| {bool, false | true}
| nil
| {var, var_name()}
| {con, arities(), tag(), [fexpr()]}
| {tuple, [fexpr()]}
| {proj, fexpr(), integer()}
| {set_proj, fexpr(), integer(), fexpr()} %% tuple, field, new_value
@ -47,6 +48,7 @@
| {int, integer()}
| nil
| {'::', var_name(), var_name()}
| {con, arities(), tag(), [var_name()]}
| {tuple, [var_name()]}.
-type ftype() :: integer
@ -77,8 +79,15 @@
-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 fun_env() :: #{ sophia_name() => fun_name() }.
-type con_env() :: #{ sophia_name() => con_tag() }.
-type context() :: {main_contract, string()}
| {namespace, string()}
@ -86,6 +95,7 @@
-type env() :: #{ type_env := type_env(),
fun_env := fun_env(),
con_env := con_env(),
options := [option()],
context => context(),
functions := #{ fun_name() => fun_def() } }.
@ -104,6 +114,9 @@ ast_to_fcode(Code, Options) ->
init_env(Options) ->
#{ type_env => init_type_env(),
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,
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) ->
Q = qname(Env, Name),
FDef = fun(Args) ->
Sub = maps:from_list(lists:zip([X || {tvar, _, X} <- Xs], Args)),
case Def of
{record_t, Fields} -> {todo, Xs, Args, record_t, Fields};
{variant_t, Cons} -> {todo, Xs, Args, variant_t, Cons};
{variant_t, Cons} ->
FCons = [ begin
{constr_t, _, _, Ts} = Con,
[type_to_fcode(Env, Sub, T) || T <- Ts]
end || Con <- Cons ],
{variant, FCons};
{alias_t, Type} -> {todo, Xs, Args, alias_t, Type}
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().
type_to_fcode(Env, {app_t, _, T = {Id, _, _}, Types}) when Id == id; Id == qid ->
lookup_type(Env, T, [type_to_fcode(Env, Type) || Type <- Types]);
type_to_fcode(Env, T = {Id, _, _}) when Id == id; Id == qid ->
type_to_fcode(Env, Type) ->
type_to_fcode(Env, #{}, Type).
-spec type_to_fcode(env(), #{var_name() => ftype()}, aeso_syntax:type()) -> ftype().
type_to_fcode(Env, Sub, {app_t, _, T = {Id, _, _}, Types}) when Id == id; Id == qid ->
lookup_type(Env, T, [type_to_fcode(Env, Sub, Type) || Type <- Types]);
type_to_fcode(Env, _Sub, T = {Id, _, _}) when Id == id; Id == qid ->
lookup_type(Env, T, []);
type_to_fcode(Env, {tuple_t, _, Types}) ->
{tuple, [type_to_fcode(Env, T) || T <- Types]};
type_to_fcode(Env, {record_t, Fields}) ->
type_to_fcode(Env, Sub, {tuple_t, _, Types}) ->
{tuple, [type_to_fcode(Env, Sub, T) || T <- Types]};
type_to_fcode(Env, Sub, {record_t, Fields}) ->
FieldType = fun({field_t, _, _, Ty}) -> Ty end,
type_to_fcode(Env, {tuple_t, [], lists:map(FieldType, Fields)});
type_to_fcode(_Env, Type) ->
type_to_fcode(Env, Sub, {tuple_t, [], lists:map(FieldType, Fields)});
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}).
-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
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
expr_to_fcode(Env, _Type, {tuple, _, Es}) ->
{tuple, [expr_to_fcode(Env, E) || E <- Es]};
@ -312,7 +365,8 @@ alts_to_fcode(Env, Type, X, Alts) ->
| {bool, false | true}
| {int, integer()}
| nil | {'::', fpat(), fpat()}
| {tuple, [fpat()]}.
| {tuple, [fpat()]}
| {con, arities(), tag(), [fpat()]}.
%% %% Invariant: the number of variables matches the number of patterns in each falt.
-spec split_tree(env(), [{var_name(), ftype()}], [falt()]) -> fsplit().
@ -352,6 +406,8 @@ merge_alt(I, X, {P, A}, [{Q, As} | Rest]) ->
({int, N}, {int, N}) -> match;
(nil, nil) -> match;
({'::', _, _}, {'::', _, _}) -> match;
({con, _, C, _}, {con, _, C, _}) -> match;
({con, _, _, _}, {con, _, _, _}) -> mismatch;
({var, _}, _) -> expand;
(_, {var, _}) -> insert;
(_, _) -> mismatch
@ -367,21 +423,25 @@ merge_alt(I, X, {P, A}, [{Q, As} | Rest]) ->
expand(I, X, P, Q, Case = {'case', Ps, E}) ->
{Ps0, [{var, Y} | Ps1]} = lists:split(I - 1, Ps),
{Ps0r, Ren1} = rename_pats([{Y, X} || Y /= X], Ps0),
{Ps1r, Ren2} = rename_pats(Ren1, Ps1),
{Ps0r, Ren1} = rename_fpats([{Y, X} || Y /= X], Ps0),
{Ps1r, Ren2} = rename_fpats(Ren1, Ps1),
E1 = rename(Ren2, E),
Splice = fun(N) -> Ps0r ++ lists:duplicate(N, {var, "_"}) ++ Ps1r end,
Type = fun({tuple, Xs}) -> {tuple, length(Xs)};
({bool, _}) -> bool;
({int, _}) -> int;
(nil) -> list;
({'::', _, _}) -> list end,
({'::', _, _}) -> list;
({con, As, _, _}) -> {variant, As}
end,
MkCase = fun(Pat, Vars) -> {Pat, {'case', Splice(Vars), E1}} end,
case Type(Q) of
{tuple, N} -> {[MkCase(Q, N)], []};
bool -> {[MkCase({bool, B}, 0) || B <- [false, true]], []};
int -> {[MkCase(Q, 0)], [{P, Case}]};
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.
-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(nil) -> {nil, []};
split_pat({'::', P, Q}) -> {{'::', fresh_name(), fresh_name()}, [P, Q]};
split_pat({con, As, I, Pats}) ->
Xs = [fresh_name() || _ <- Pats],
{{con, As, I, Xs}, Pats};
split_pat({tuple, Pats}) ->
Xs = [fresh_name() || _ <- Pats],
{{tuple, Xs}, Pats}.
@ -405,6 +468,8 @@ split_vars({bool, _}, boolean) -> [];
split_vars({int, _}, integer) -> [];
split_vars(nil, {list, _}) -> [];
split_vars({'::', X, Xs}, {list, T}) -> [{X, T}, {Xs, {list, T}}];
split_vars({con, _, I, Xs}, {variant, Cons}) ->
lists:zip(Xs, lists:nth(I + 1, Cons));
split_vars({tuple, Xs}, {tuple, Ts}) ->
lists:zip(Xs, Ts);
split_vars({var, X}, T) -> [{X, T}].
@ -416,6 +481,7 @@ rename(Ren, Expr) ->
{bool, _} -> Expr;
nil -> nil;
{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]};
{proj, E, I} -> {proj, rename(Ren, E), I};
{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),
{[Z | Zs], Ren2}.
rename_pats(Ren, []) -> {[], Ren};
rename_pats(Ren, [P | Ps]) ->
{Q, Ren1} = rename_pat(Ren, P),
{Qs, Ren2} = rename_pats(Ren1, Ps),
rename_fpats(Ren, []) -> {[], Ren};
rename_fpats(Ren, [P | Ps]) ->
{Q, Ren1} = rename_fpat(Ren, P),
{Qs, Ren2} = rename_fpats(Ren1, Ps),
{[Q | Qs], Ren2}.
rename_pat(Ren, P = {bool, _}) -> {P, Ren};
rename_pat(Ren, P = {int, _}) -> {P, Ren};
rename_pat(Ren, P = nil) -> {P, Ren};
rename_pat(Ren, {'::', P, Q}) ->
{P1, Ren1} = rename_pat(Ren, P),
{Q1, Ren2} = rename_pat(Ren1, Q),
rename_fpat(Ren, P = {bool, _}) -> {P, Ren};
rename_fpat(Ren, P = {int, _}) -> {P, Ren};
rename_fpat(Ren, P = nil) -> {P, Ren};
rename_fpat(Ren, {'::', P, Q}) ->
{P1, Ren1} = rename_fpat(Ren, P),
{Q1, Ren2} = rename_fpat(Ren1, Q),
{{'::', P1, Q1}, Ren2};
rename_pat(Ren, {var, X}) ->
rename_fpat(Ren, {var, X}) ->
{Z, Ren1} = rename_binding(Ren, X),
{{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),
{{tuple, Zs}, Ren1}.
@ -467,7 +553,7 @@ rename_split(Ren, {split, Type, X, Cases}) ->
rename_split(Ren, {nosplit, E}) -> {nosplit, rename(Ren, E)}.
rename_case(Ren, {'case', Pat, Split}) ->
{Pat1, Ren1} = rename_pat(Ren, Pat),
{Pat1, Ren1} = rename_spat(Ren, Pat),
{'case', Pat1, rename_split(Ren1, Split)}.
-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().
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}) ->
{tuple, [ pat_to_fcode(Env, Pat) || Pat <- Pats ]};
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) ->
Env#{ type_env := TEnv#{ Q => FDef } }.
-spec bind_constructors(env(), con_env()) -> env().
bind_constructors(Env = #{ con_env := ConEnv }, NewCons) ->
Env#{ con_env := maps:merge(ConEnv, NewCons) }.
%% -- Names --
-spec add_fun_env(env(), [aeso_syntax:decl()]) -> env().
@ -600,6 +695,15 @@ lookup_fun(#{ fun_env := FunEnv }, Name) ->
FName -> FName
end.
-spec lookup_con(env(), aeso_syntax:con() | aeso_syntax:qcon() | sophia_name()) -> con_tag().
lookup_con(Env, {con, _, Con}) -> lookup_con(Env, [Con]);
lookup_con(Env, {qcon, _, Con}) -> lookup_con(Env, Con);
lookup_con(#{ con_env := ConEnv }, Con) ->
case maps:get(Con, ConEnv, false) of
false -> error({unbound_constructor, Con});
Tag -> Tag
end.
init_fresh_names() ->
put('%fresh', 0).
@ -640,6 +744,9 @@ get_attributes(Ann) ->
indexed(Xs) ->
lists:zip(lists:seq(1, length(Xs)), Xs).
fcode_error(Err) ->
error(Err).
%% -- Pretty printing --------------------------------------------------------
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_parens(Doc) ->
pp_beside([pp_text("("), Doc, pp_text(")")]).
pp_parens(Doc) -> pp_beside([pp_text("("), Doc, pp_text(")")]).
pp_braces(Doc) -> pp_beside([pp_text("{"), Doc, pp_text("}")]).
pp_punctuate(_Sep, []) -> [];
pp_punctuate(_Sep, [X]) -> [X];
@ -674,10 +781,17 @@ pp_fexpr(nil) ->
pp_text("[]");
pp_fexpr({var, 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_parens(prettypr:par(pp_punctuate(pp_text(","), [pp_fexpr(E) || E <- Es])));
pp_fexpr({proj, E, 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_parens(prettypr:par([pp_fexpr(A), pp_text(Op), pp_fexpr(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_parens(prettypr:par(pp_punctuate(pp_text(","), [pp_ftype(T) || T <- Ts])));
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({split, Type, X, Alts}) ->
@ -702,5 +823,6 @@ pp_case({'case', Pat, Split}) ->
pp_pat({tuple, Xs}) -> pp_fexpr({tuple, [{var, X} || X <- Xs]});
pp_pat({'::', X, Xs}) -> pp_fexpr({binop, '::', {var, X}, {var, Xs}});
pp_pat({con, As, I, Xs}) -> pp_fexpr({con, As, I, [{var, X} || X <- Xs]});
pp_pat(Pat) -> pp_fexpr(Pat).

78
src/aeso_fcode_to_fate.erl
View File

@ -28,7 +28,7 @@
-type var() :: {var, integer()}.
-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_a() :: missing | scode_a().
@ -53,6 +53,7 @@
Op =:= 'AND' orelse
Op =:= 'OR' orelse
Op =:= 'ELEMENT' orelse
Op =:= 'VARIANT_ELEMENT' orelse
Op =:= 'CONS')).
-define(IsUnOp(Op),
@ -100,10 +101,16 @@ functions_to_scode(Functions, Options) ->
function_to_scode(Name, Args, Body, ResType, Options) ->
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),
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 ----------------------------------------------------------------
%% Icode to structured assembly
@ -145,6 +152,11 @@ to_scode(_Env, nil) -> aeb_fate_code:nil(?a);
to_scode(Env, {var, 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}) ->
N = length(As),
[[ to_scode(Env, A) || A <- As ],
@ -182,13 +194,14 @@ split_to_scode(Env, {nosplit, Expr}) ->
[switch_body, to_scode(Env, Expr)];
split_to_scode(Env, {split, {tuple, _}, X, Alts}) ->
{Def, Alts1} = catchall_to_scode(Env, X, Alts),
Arg = lookup_var(Env, X),
Alt = case [ {Xs, Split} || {'case', {tuple, Xs}, Split} <- Alts1 ] of
[] -> missing;
[{Xs, S} | _] ->
{Code, Env1} = match_tuple(Env, Xs),
{Code, Env1} = match_tuple(Env, Arg, Xs),
[Code, split_to_scode(Env1, S)]
end,
[aeb_fate_code:push(lookup_var(Env, X)),
[aeb_fate_code:push(Arg),
case Def == missing andalso Alt /= missing of
true -> Alt; % skip the switch if single tuple pattern
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}) ->
{Def, Alts1} = catchall_to_scode(Env, X, Alts),
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, _, _, _}) ->
?TODO({'case', Split}).
@ -250,18 +277,20 @@ catchall_to_scode(Env, X, [Alt | Alts], Acc) ->
catchall_to_scode(_, _, [], Acc) -> {missing, lists:reverse(Acc)}.
%% Tuple is in the accumulator. Arguments are the variable names.
match_tuple(Env, Xs) ->
match_tuple(Env, 0, Xs).
match_tuple(Env, Arg, Xs) ->
match_tuple(Env, 0, fun aeb_fate_code:element_op/3, Arg, Xs).
match_tuple(Env, I, ["_" | Xs]) ->
match_tuple(Env, I + 1, Xs);
match_tuple(Env, I, [X | Xs]) ->
match_variant(Env, Arg, Xs) ->
Elem = fun(Dst, I, Val) -> aeb_fate_code:variant_element(Dst, Val, I) end,
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),
{Code, Env2} = match_tuple(Env1, I + 1, Xs),
{[ [aeb_fate_code:dup() || [] /= [Y || Y <- Xs, Y /= "_"]], %% Don't DUP the last one
aeb_fate_code:element_op({var, J}, ?i(I), ?a),
Code], Env2};
match_tuple(Env, _, []) ->
{Code, Env2} = match_tuple(Env1, I + 1, Elem, Arg, Xs),
{[Elem({var, J}, ?i(I), Arg), Code], Env2};
match_tuple(Env, _, _, _, []) ->
{[], Env}.
%% -- Operators --
@ -316,7 +345,8 @@ pp_ann(Ind, [{switch, Type, Alts, Def} | Code]) ->
Tags =
case Type of
boolean -> ["FALSE", "TRUE"];
tuple -> ["(_)"]
tuple -> ["(_)"];
{variant, Ar} -> ["C" ++ integer_to_list(I) || I <- lists:seq(0, length(Ar) - 1)]
end,
[[[Ind, Tag, " =>\n", pp_ann(" " ++ Ind, Alt)]
|| {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};
tuple ->
[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,
Blk2 = Blk1#blk{catchall = DefRef}, %% Update catchall ref
block(Blk2, Code1 ++ Acc, DefBlk ++ RestBlk ++ AltBlks ++ Blocks, BlockAcc);
@ -883,6 +919,7 @@ reorder_blocks(Ref, Code, Blocks, Acc) ->
['RETURN'|_] -> reorder_blocks(Blocks, Acc1);
[{'RETURNR', _}|_] -> reorder_blocks(Blocks, Acc1);
[{'ABORT', _}|_] -> reorder_blocks(Blocks, Acc1);
[{switch, _}|_] -> reorder_blocks(Blocks, Acc1);
[{jump, L}|_] ->
NotL = fun({L1, _}) -> L1 /= L end,
case lists:splitwith(NotL, Blocks) of
@ -913,6 +950,7 @@ chase_labels([L | Ls], Map, Live) ->
Code = maps:get(L, Map),
Jump = fun({jump, A}) -> [A || not maps:is_key(A, Live)];
({jumpif, A}) -> [A || not maps:is_key(A, Live)];
({switch, As}) -> [A || A <- As, not maps:is_key(A, Live)];
(_) -> [] end,
New = lists:flatmap(Jump, Code),
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 ]};
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, {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.
%% -- Helpers ----------------------------------------------------------------