Current section
Files
Jump to
Current section
Files
src/lfe_codegen.erl
%% Copyright (c) 2008-2016 Robert Virding
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
%% You may obtain a copy of the License at
%%
%% http://www.apache.org/licenses/LICENSE-2.0
%%
%% Unless required by applicable law or agreed to in writing, software
%% distributed under the License is distributed on an "AS IS" BASIS,
%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
%% See the License for the specific language governing permissions and
%% limitations under the License.
%%% File : lfe_codegen.erl
%%% Author : Robert Virding
%%% Purpose : Lisp Flavoured Erlang code generator (to core Erlang).
%%% We have to be very careful to generate annotations in exactly the
%%% same way as the erlang compiler does and in the same places.
%%% Dialyzer is very finnicky about this and seriously fails if things
%%% are not as it expects them to be. Note that now the whole
%%% annotation is passed into the constructor functions, not just the
%%% line number.
-module(lfe_codegen).
-export([module/2]).
-compile(export_all).
-import(lists, [member/2,keysearch/3,reverse/1,
all/2,map/2,foldl/3,foldr/3,mapfoldl/3,mapfoldr/3,
concat/1,zipwith/3]).
-import(ordsets, [add_element/2,is_element/2,from_list/1,union/2]).
-import(orddict, [store/3,find/2]).
-import(lfe_env, [new/0,add_env/2,
add_vbinding/3,get_vbinding/2,add_fbinding/4,get_fbinding/3,
add_ibinding/5,get_gbinding/3]).
-include("lfe_comp.hrl").
%% Define IS_MAP/1 macro for is_map/1 bif.
-ifdef(HAS_MAPS).
-define(IS_MAP(T), is_map(T)).
-else.
-define(IS_MAP(T), false).
-endif.
-define(Q(E), [quote,E]). %We do a lot of quoting!
-record(cg, {module=[], %Module name
exps=[], %Exports (ordsets)
imps=[], %Imports (orddict)
pref=[], %Prefixes
atts=[], %Attrubutes
defs=[], %Function definitions.
env=[], %Environment
anno=[], %Current annotation
opts=[], %Options
file=[], %File name
func=[], %Current function
line=0, %Current line
vc=0, %Variable counter
fc=0 %Function counter
}).
%% module(ModuleForms, CompInfo) -> {ModuleName,CoreModule}
module(Mfs, #cinfo{opts=Opts,file=File}) ->
St0 = #cg{opts=Opts,file=File},
{Core,St1} = compile_module(Mfs, St0),
{St1#cg.module,Core}.
%% compile_module(ModuleForms, State) -> {CoreModule,State}.
compile_module(Mfs, St0) ->
{Fbs,St1} = collect_module(Mfs, St0),
Core = c_module(c_atom(none), [], []),
compile_forms(Fbs, St1, Core).
%% collect_module(ModuleForms, State) -> {Fbs,State}.
%% Collect forms and module data. Returns function bindings and puts
%% module data into state.
collect_module(Mfs, St0) ->
{Acc,St1} = lists:foldl(fun collect_form/2, {[],St0}, Mfs),
{lists:reverse(Acc),St1}.
%% collect_form(Form, Line, State} -> {[Ret],State}.
%% Collect valid forms and module data. Returns forms and put module
%% data into state.
collect_form({['define-module',Mod,_Meta,Atts],L}, {Acc,St}) ->
%% Ignore the meta data, everything else into State.
{Acc,collect_attrs(Atts, L, St#cg{module=Mod,anno=[L]})};
collect_form({['extend-module',_Meta,Atts],L}, {Acc,St}) ->
%% Ignore the meta data, everything else into State.
{Acc,collect_attrs(Atts, L, St#cg{anno=[L]})};
collect_form({['define-function',Name,_Meta,Def],L}, {Acc,St}) ->
%% Ignore the meta data.
{[{Name,Def,L}|Acc],St};
%% Ignore macro definitions and eval-when-compile forms.
collect_form({['define-macro'|_],_}, {Acc,St}) -> {Acc,St};
collect_form({['eval-when-compile'|_],_}, {Acc,St}) -> {Acc,St}.
%% collect_attrs(Attributes, Line, State) -> State.
%% Collect module attributes and fill in the #cg state record. Need
%% to ignore all eventual doc attributes.
collect_attrs(As, L, St) ->
%% io:format("ca: ~p\n", [As]),
foldl(fun (A, S) -> collect_attr(A, L, S) end, St, As).
collect_attr([export|Es], _, St) -> collect_exps(Es, St);
collect_attr([import|Is], _, St) -> collect_imps(Is, St);
collect_attr([doc|_], _, St) -> St; %Don't save doc attribute!
collect_attr([N|Vs], L, #cg{atts=As}=St) ->
St#cg{atts=As ++ [{N,Vs,L}]}. %Probably not many
collect_exps([all], St) -> St#cg{exps=all}; %Propagate all
collect_exps(_, #cg{exps=all}=St) -> St;
collect_exps(Es, #cg{exps=Exps0}=St) ->
%% Add exports to export set.
Exps1 = foldl(fun ([F,A], E) -> add_element({F,A}, E) end,
Exps0, Es),
St#cg{exps=Exps1}.
collect_imps(Is, St) ->
foldl(fun (I, S) -> collect_imp(I, S) end, St, Is).
collect_imp(['from',Mod|Fs], St) ->
collect_imp(fun ([F,A], Imps) -> store({F,A}, F, Imps) end,
Mod, St, Fs);
collect_imp(['rename',Mod|Rs], St) ->
collect_imp(fun ([[F,A],R], Imps) -> store({F,A}, R, Imps) end,
Mod, St, Rs);
collect_imp(['prefix',Mod,Pre], St) ->
Pstr = atom_to_list(Pre), %Store prefix as string
St#cg{pref=store(Pstr, Mod, St#cg.pref)}.
collect_imp(Fun, Mod, St, Fs) ->
Imps0 = safe_fetch(Mod, St#cg.imps, []),
Imps1 = foldl(Fun, Imps0, Fs),
St#cg{imps=store(Mod, Imps1, St#cg.imps)}.
%% compile_forms(Forms, State, CoreModule) -> {CoreModule,State}.
%% Compile the forms from the file as stored in the state record.
compile_forms(Fbs0, St0, Core0) ->
%% Add predefined functions and definitions, these are in line 0.
Predefs = [{module_info,0},{module_info,1}],
Mibs = [{module_info,
[lambda,[],
[call,?Q(erlang),?Q(get_module_info),?Q(St0#cg.module)]],0},
{module_info,
[lambda,[x],
[call,?Q(erlang),?Q(get_module_info),?Q(St0#cg.module),x]],0}],
%% The sum of all functions.
Fbs1 = Fbs0 ++ Mibs,
%% Make initial environment and set state.
Env = forms_env(Fbs1, St0),
St1 = St0#cg{exps=add_exports(St0#cg.exps, Predefs),
defs=Fbs1,env=Env},
Exps = make_exports(St1#cg.exps, Fbs1),
Atts = map(fun ({N,V,L}) ->
Ann = [L],
{ann_c_lit(Ann, N),ann_c_lit(Ann, V)}
end, St1#cg.atts),
%% Compile the functions.
{Cdefs,St2} = mapfoldl(fun (D, St) -> comp_define(D, Env, St) end,
St1, St1#cg.defs),
%% Build the final core module structure.
Core1 = update_c_module(Core0, c_atom(St2#cg.module), Exps, Atts, Cdefs),
%% Maybe print lots of debug info.
?DEBUG("#cg: ~p\n", [St2], St2#cg.opts),
?DEBUG("core_lint: ~p\n", [(catch core_lint:module(Core1))], St2#cg.opts),
?DEBUG("#core: ~p\n", [Core1], St2#cg.opts),
%% ?DEBUG("core_pp: ~p\n",
%% [(catch io:put_chars([core_pp:format(Core1),$\n]))], St2#cg.opts),
{Core1,St2}.
forms_env(Fbs, St) ->
%% Make initial environment with imports and local functions.
Env = foldl(fun ({M,Fs}, Env) ->
foldl(fun ({{F,A},R}, E) ->
add_ibinding(M, F, A, R, E)
end, Env, Fs)
end, lfe_env:new(), St#cg.imps),
foldl(fun ({Name,Def,_}, E) ->
add_fbinding(Name, func_arity(Def), Name, E)
end, Env, Fbs).
add_exports(all, _) -> all;
add_exports(Old, More) -> union(Old, More).
make_exports(all, Fbs) ->
map(fun ({F,Def,_}) -> c_fname(F, func_arity(Def)) end, Fbs);
make_exports(Exps, _) ->
map(fun ({F,A}) -> c_fname(F, A) end, Exps).
%% comp_define(DefForm, Env, State) -> {Corefunc,State}.
%% Compile a top-level define. Sets current function name. Be careful
%% with annotations as dialyzer then sometimes goes crazy.
comp_define({Name,Def,L}, Env, St) ->
Ann = [L],
Cf = {Name,func_arity(Def)}, %Is useful
comp_func(Name, Def, Env, L, St#cg{func=Cf,line=L,vc=0,fc=0,anno=Ann}).
%% comp_body(BodyList, Env, Line, State) -> {CoreBody,State}.
%% Compile a body list of expressions.
comp_body([E], Env, L, St) -> comp_expr(E, Env, L, St);
comp_body([E|Es], Env, L, St0) ->
{Ce,St1} = comp_expr(E, Env, L, St0),
{Cb,St2} = comp_body(Es, Env, L, St1),
{append_c_seq(Ce, Cb, L),St2}; %Flatten nested sequences
comp_body([], _, _, St) -> {c_nil(),St}. %Empty body returns []
append_c_seq(Ce, Cb, L) ->
case is_c_seq(Ce) of
true -> update_c_seq(Ce, seq_arg(Ce), seq_body(Ce));
false -> ann_c_seq([L], Ce, Cb)
end.
%% comp_expr(Expr, Env, Line, State) -> {CoreExpr,State}.
%% Compile an expression.
%% Handle the Core data special forms.
comp_expr([quote,E], _, _, St) -> {comp_lit(E),St};
comp_expr([cons,H,T], Env, L, St) ->
Cons = fun ([Ch,Ct], _, _, Sta) -> {c_cons(Ch, Ct),Sta} end,
comp_args([H,T], Cons, Env, L, St);
comp_expr([car,E], Env, L, St) -> %Provide lisp names
comp_expr([hd,E], Env, L, St);
comp_expr([cdr,E], Env, L, St) ->
comp_expr([tl,E], Env, L, St);
comp_expr([list|Es], Env, L, St) ->
List = fun (Ces, _, _, Sta) ->
{foldr(fun (E, T) -> c_cons(E, T) end, c_nil(), Ces),Sta}
end,
comp_args(Es, List, Env, L, St);
comp_expr([tuple|As], Env, L, St) ->
Args = fun (Args, _, _, Sta) -> {c_tuple(Args),Sta} end,
comp_args(As, Args, Env, L, St);
comp_expr([binary|Segs], Env, L, St) ->
comp_binary(Segs, Env, L, St); %And bitstring as well
comp_expr([map|As], Env, L, St) ->
comp_map(As, Env, L, St);
comp_expr(['mref',Map,K], Env, L, St) ->
%% Sneaky, but no other real option for now.
comp_expr([call,?Q(maps),?Q(get),K,Map], Env, L, St);
comp_expr(['mset',Map|As], Env, L, St) ->
comp_set_map(Map, As, Env, L, St);
comp_expr(['mupd',Map|As], Env, L, St) ->
comp_upd_map(Map, As, Env, L, St);
comp_expr(['map-get',Map,K], Env, L, St) ->
comp_expr(['mref',Map,K], Env, L, St);
comp_expr(['map-set',Map|As], Env, L, St) ->
comp_expr(['mset',Map|As], Env, L, St);
comp_expr(['map-update',Map|As], Env, L, St) ->
comp_expr(['mupd',Map|As], Env, L, St);
%% Handle the Core closure special forms.
comp_expr([lambda,Args|Body], Env, L, St) ->
comp_lambda(Args, Body, Env, L, St);
comp_expr(['match-lambda'|Cls], Env, L, St) ->
comp_match_lambda(Cls, Env, L, St);
comp_expr(['let',Vbs|Body], Env, L, St) ->
comp_let(Vbs, Body, Env, L, St);
comp_expr(['let-function',Fbs|Body], Env, L, St) ->
comp_let_function(Fbs, Body, Env, L, St);
comp_expr(['letrec-function',Fbs|Body], Env, L, St) ->
comp_letrec_function(Fbs, Body, Env, L, St);
%% (let-syntax ...) should never be seen here!
%% Handle the Core control special forms.
comp_expr(['progn'|Body], Env, L, St) ->
comp_body(Body, Env, L, St);
comp_expr(['if'|Body], Env, L, St) ->
comp_if(Body, Env, L, St);
comp_expr(['case',Expr|Cls], Env, L, St) ->
comp_case(Expr, Cls, Env, L, St);
comp_expr(['receive'|Cls], Env, L, St0) ->
{Ccs,Ct,Ca,St1} = rec_clauses(Cls, Env, L, St0),
{ann_c_receive([L], Ccs, Ct, Ca),St1};
comp_expr(['catch'|Body], Env, L, St0) ->
{Cb,St1} = comp_body(Body, Env, L, St0),
{ann_c_catch([L], Cb),St1};
comp_expr(['try'|B], Env, L, St) ->
comp_try(B, Env, L, St);
comp_expr(['funcall',F|As], Env, L, St) ->
comp_funcall(F, As, Env, L, St);
%%comp_expr([call,[quote,erlang],[quote,primop]|As], Env, L, St) ->
%% An interesting thought to open up system.
comp_expr([call,M,N|As], Env, L, St) ->
%% Call a function in another module.
Call = fun ([Cm,Cn|Cas], _, Li, Sta) ->
Ann = line_file_anno(Li, Sta),
{ann_c_call(Ann, Cm, Cn, Cas),Sta}
end,
comp_args([M,N|As], Call, Env, L, St);
%% General function calls.
comp_expr([Fun|As], Env, L, St) when is_atom(Fun) ->
%% Fun is a symbol which is either a known BIF or function.
Call = fun (Cas, En, Li, Sta) ->
Ar = length(Cas),
Ann = line_file_anno(Li, Sta),
case get_fbinding(Fun, Ar, En) of
{yes,M,F} -> %Import
{ann_c_call(Ann, c_atom(M), c_atom(F), Cas),Sta};
{yes,Name} ->
%% Might have been renamed, use real function name.
{ann_c_apply(Ann, c_fname(Name, Ar), Cas),Sta};
no ->
%% io:format("ce: ~p\n", [{{Fun,Ar},En}]),
error(foo)
end
end,
comp_args(As, Call, Env, L, St);
comp_expr(Symb, _, _, St) when is_atom(Symb) ->
{c_var(Symb),St};
%% Everything is a literal constant (nil, tuples, numbers, binaries, maps).
comp_expr(Const, _, _, St) ->
{comp_lit(Const),St}.
%% comp_args(Args, CallFun, Env, Line, State) -> {Call,State}.
%% Sequentialise the evaluation of Args building the Call at the
%% bottom. For non-simple arguments use let to break the arg
%% evaluation out from the main call.
comp_args(As, Call, Env, L, St0) ->
{Cas,St1} = mapfoldl(fun (A, St) -> comp_expr(A, Env, L, St) end, St0, As),
simple_seq(Cas, Call, Env, L, St1).
%% simple_seq(CoreExps, Then, Env, Line, State) -> {Cepxr,State}.
%% Sequentialise the evaluation of a sequence of core expressions
%% using let's for non-simple exprs, and call Then with the simple
%% core sequence. Cannot use a simple foldr as we pass data both in
%% and out.
simple_seq(Ces, Then, Env, L, St) -> simple_seq(Ces, Then, [], Env, L, St).
simple_seq([Ce|Ces], Then, Ses, Env, L, St0) ->
%% Use erlang core compiler lib which does what we want.
case is_simple(Ce) of
true -> simple_seq(Ces, Then, [Ce|Ses], Env, L, St0);
false ->
{Cv,St1} = new_c_var(L, St0),
{Rest,St2} = simple_seq(Ces, Then, [Cv|Ses], Env, L, St1),
{ann_c_let([L], [Cv], Ce, Rest),St2}
end;
simple_seq([], Then, Ses, Env, L, St) ->
Then(reverse(Ses), Env, L, St).
%% comp_lambda(Args, Body, Env, Line, State) -> {c_fun(),State}.
%% Compile a (lambda (...) ...).
comp_lambda(Args, Body, Env, L, St0) ->
{Cvs,Pvs,St1} = comp_lambda_args(Args, L, St0),
{Cb,St2} = comp_body(Body, add_vbindings(Pvs, Env), L, St1),
Ann = line_file_anno(L, St2),
{ann_c_fun(Ann, Cvs, Cb),St2}.
comp_lambda_args(Args, L, St) ->
foldr(fun (A, {Cvs,Pvs0,St0}) ->
{Cv,Pvs1,St1} = pat_symb(A, L, Pvs0, St0),
{[Cv|Cvs],Pvs1,St1}
end, {[],[],St}, Args).
%% lambda_arity([Args|_]) -> length(Args).
%% comp_match_lambda(Clauses, Env, Line, State) -> {c_fun(),State}.
%% (match-lambda (Pat ...) ...).
comp_match_lambda(Cls, Env, L, St0) ->
Ar = match_lambda_arity(Cls),
{Cvs,St1} = new_c_vars(Ar, L, St0),
{Ccs,St2} = comp_match_clauses(Cls, Env, L, St1),
{Fvs,St3} = new_c_vars(Ar, L, St2),
Cf = func_fail(Fvs, L, St3),
Ann = line_file_anno(L, St3),
Cb = ann_c_case(Ann, ann_c_values(Ann, Cvs), Ccs ++ [Cf]),
{ann_c_fun(Ann, Cvs, Cb),St3}.
func_fail(Fvs, L, #cg{func=F}=St) ->
%% We need function_name anno to generate function_clause error.
fail_clause(Fvs, c_tuple([c_atom(function_clause)|Fvs]),
[{function_name,F}], L, St).
%% match_lambda_arity(MatchClauses) -> int().
match_lambda_arity([[Pats|_]|_]) -> length(Pats).
comp_match_clauses(Cls, Env, L, St) ->
mapfoldl(fun (Cl, Sta) -> comp_match_clause(Cl, Env, L, Sta) end,
St, Cls).
%% comp_match_clause(Clause, Env, L, State) -> {c_clause(),State}.
%% (Pats [(when Guard)] . Body)
%% Pats is here a list of patterns which are the function clause
%% arguments. This must be compiled to a list of patterns not a
%% pattern with a list!
comp_match_clause([Pats|Body], Env0, L, St0) ->
Pfun = fun (P, {Psvs,Sta}) ->
{Cp,Pvs,Stb} = pattern(P, L, Sta),
{Cp,{union(Pvs, Psvs),Stb}}
end,
{Cps,{Pvs,St1}} = mapfoldl(Pfun, {[],St0}, Pats),
Env1 = add_vbindings(Pvs, Env0),
{Cg,Cb,St2} = comp_clause_body(Body, Env1, L, St1),
Ann = line_file_anno(L, St2),
{ann_c_clause(Ann, Cps, Cg, Cb),St2}.
%% comp_let(VarBindings, Body, Env, L, State) -> {c_let()|c_case(),State}.
%% Compile a let expr. We are a little cunning in that we specialise
%% the the case where all the patterns are variables and there are no
%% guards, the simple case.
comp_let(Vbs, B, Env, L, St0) ->
%% Test if this is a simple let, i.e. no matching.
Simple = all(fun ([Pat,_]) -> is_atom(Pat);
(_) -> false %Has guard
end, Vbs),
case Simple of
true ->
%% This is not really necessary, but fun.
{Cvs,Pvs,St1} = comp_lambda_args([ V || [V|_] <- Vbs ], L, St0),
Efun = fun ([_,E], St) -> comp_expr(E, Env, L, St) end,
{Ces,St2} = mapfoldl(Efun, St1, Vbs),
{Cb,St3} = comp_body(B, add_vbindings(Pvs, Env), L, St2),
{ann_c_let([L], Cvs, ann_c_values([L], Ces), Cb),St3};
false ->
%% This would be much easier to do by building a clause
%% and compiling it directly, but then we would have to
%% build a tuple to hold all values.
Pfun = fun ([P|_], {Psvs,Sta}) ->
{Cp,Pvs,Stb} = pattern(P, L, Sta),
{Cp,{union(Pvs, Psvs),Stb}}
end,
{Cps,{Pvs,St1}} = mapfoldl(Pfun, {[],St0}, Vbs),
%% Build a sequence of guard tests.
Gfun = fun ([_,['when'|G]|_], Cgs) -> G ++ Cgs;
(_, Cgs) -> Cgs
end,
Gs = foldr(Gfun, [], Vbs),
Efun = fun ([_,_,E], St) -> comp_expr(E, Env, L, St);
([_,E], St) -> comp_expr(E, Env, L, St)
end,
{Ces,St2} = mapfoldl(Efun, St1, Vbs),
Env1 = add_vbindings(Pvs, Env),
{Cg,St3} = comp_guard(Gs, Env1, L, St2),
{Cb,St4} = comp_body(B, Env1, L, St3),
{Cvs,St5} = new_c_vars(length(Ces), L, St4),
Cf = let_fail(Cvs, L, St5),
{ann_c_case([L], ann_c_values([L], Ces),
[ann_c_clause([L], Cps, Cg, Cb),Cf]),
St5}
end.
let_fail(Cvs, L, St) ->
fail_clause(Cvs, c_tuple([c_atom(badmatch),c_tuple(Cvs)]), [], L, St).
%% comp_let_function(FuncBindngs, Body, Env, Line, State) ->
%% {c_letrec(),State}.
%% Compile an flet. This is complicated by the fact that Core only
%% has letrec so we have to some name munging of the functions to
%% avoid recursive definitions.
comp_let_function(Fbs0, B, Env0, L, St0) ->
%% Munge names of functions. Don't use new_symb as we want to link
%% new names to original.
Nfun = fun ([Old,Def], S0) ->
{New,S1} = new_fun_name(atom_to_list(Old), S0),
{{Old,New,Def},S1}
end,
{Nfbs,St1} = mapfoldl(Nfun, St0, Fbs0),
%% Now compile functions in old environment.
Ffun = fun ({_,New,Def}, St) -> comp_func(New, Def, Env0, L, St) end,
{Cfs,St2} = mapfoldl(Ffun, St1, Nfbs),
%% Add local functions Env mapping old name to new.
Efun = fun ({Old,New,Def}, E) ->
add_fbinding(Old, func_arity(Def), New, E)
end,
Env1 = foldl(Efun, Env0, Nfbs),
{Cb,St3} = comp_body(B, Env1, L, St2),
{ann_c_letrec([L], Cfs, Cb),St3}.
%% comp_letrec_function(FuncBindngs, Body, Env, Line, State) ->
%% {c_letrec(),State}.
comp_letrec_function(Fbs, B, Env0, L, St0) ->
%% Add local functions Env.
Efun = fun ([Name,Def], E) ->
add_fbinding(Name, func_arity(Def), Name, E)
end,
Env1 = foldl(Efun, Env0, Fbs),
%% Now compile functions in new environment.
Ffun = fun ([Name,Def], St) -> comp_func(Name, Def, Env1, L, St) end,
{Cfs,St1} = mapfoldl(Ffun, St0, Fbs),
{Cb,St2} = comp_body(B, Env1, L, St1),
{ann_c_letrec([L], Cfs, Cb),St2}.
%% func_arity(FuncDef) -> Arity.
%% Return the arity of a function definition.
func_arity([lambda,Args|_]) -> length(Args);
func_arity(['match-lambda'|Cls]) ->
match_lambda_arity(Cls).
%% comp_func(FuncName, FuncDef, Env, L, State) -> {{Fname,Cfun},State}.
%% NEVER annotate the Fname c-form, dialyzer goes crazy then for some
%% strange reason!
comp_func(Name, [lambda,Args|Body], Env, L, St0) ->
Cf = c_fname(Name, length(Args)),
{Cfun,St1} = comp_lambda(Args, Body, Env, L, St0),
{{Cf,Cfun},St1};
comp_func(Name, ['match-lambda'|Cls], Env, L, St0) ->
Cf = c_fname(Name, match_lambda_arity(Cls)),
{Cfun,St1} = comp_match_lambda(Cls, Env, L, St0),
{{Cf,Cfun},St1}.
%% comp_if(IfBody, Env, Line, State) -> {c_case(),State}.
%% Compile in if form to a case testing the Test expression.
comp_if([Test,True], Env, L, St) ->
comp_if(Test, True, ?Q(false), Env, L, St);
comp_if([Test,True,False], Env, L, St) ->
comp_if(Test, True, False, Env, L, St).
comp_if(Te, Tr, Fa, Env, L, St0) ->
{Cte,St1} = comp_expr(Te, Env, L, St0), %Test expression
{Ctr,St2} = comp_expr(Tr, Env, L, St1), %True expression
{Cfa,St3} = comp_expr(Fa, Env, L, St2), %False expression
True = c_atom(true),
False = c_atom(false),
Ctrue = ann_c_clause([L], [True], Ctr),
Cfalse = ann_c_clause([L], [False], Cfa),
Cfail = if_fail(L, St3),
{ann_c_case([L], Cte, [Ctrue,Cfalse,Cfail]),St3}.
%% This produces code which is harder to optimise, strangely enough.
%% comp_if(Te, Tr, Fa, Env, L, St0) ->
%% {Cte,St1} = comp_expr(Te, Env, L, St0), %Test expression
%% {Ctr,St2} = comp_expr(Tr, Env, L, St1), %True expression
%% {Cfa,St3} = comp_expr(Fa, Env, L, St2), %False expression
%% If = fun ([Ctest], _, _, St) ->
%% True = c_atom(true),
%% False = c_atom(false),
%% Ctrue = ann_c_clause([L], [True], Ctr),
%% Cfalse = ann_c_clause([L], [Fail], Cfa),
%% Cfail = if_fail(L, St),
%% {ann_c_case([L], Ctest, [Ctrue,Cfalse,Cfail]),St}
%% end,
%% simple_seq([Cte], If, Env, L, St3).
if_fail(L, St) ->
Cv = c_var(omega),
fail_clause([Cv], c_atom(if_clause), [], L, St).
%% fail_clause(Pats, Arg, FailAnno, Line, State) -> Clause.
%% Build a general failure clause. No line number in the clause, but
%% append the line number and file name to the annotation.
fail_clause(Pats, Arg, Fann, L, St) ->
Ann = line_file_anno(L, St),
ann_c_clause(comp_gen_anno(L, St), %It is compiler generated
Pats, ann_c_primop(Fann ++ Ann, c_atom(match_fail), [Arg])).
%% comp_case(Expr, Clauses, Env, Line, State) -> {c_case(),State}.
%% Compile a case.
comp_case(E, Cls, Env, L, St0) ->
{Ce,St1} = comp_expr(E, Env, L, St0),
{Ccs,St2} = case_clauses(Cls, Env, L, St1),
Cf = case_fail(L, St2),
{ann_c_case([L], Ce, Ccs ++ [Cf]),St2}.
case_clauses(Cls, Env, L, St) ->
mapfoldl(fun (Cl, Sta) -> comp_clause(Cl, Env, L, Sta) end,
St, Cls).
case_fail(L, St) ->
Cv = c_var(omega),
fail_clause([Cv], c_tuple([c_atom(case_clause),Cv]), [], L, St).
%% rec_clauses(RecClauses, Env, Line, State) -> {Clause,Timeout,After,State}.
rec_clauses([['after',T|B]], Env, L, St0) ->
{Ct,St1} = comp_expr(T, Env, L, St0),
{Ca,St2} = comp_body(B, Env, L, St1),
{[],Ct,Ca,St2};
rec_clauses([Cl|Cls], Env, L, St0) ->
{Cc,St1} = comp_clause(Cl, Env, L, St0),
{Ccs,Ct,Ca,St2} = rec_clauses(Cls, Env, L, St1),
{[Cc|Ccs],Ct,Ca,St2};
rec_clauses([], _, _, St) ->
{[],c_atom(infinity),c_atom(true),St}.
%% comp_clause(Clause, Env, Line, State) -> {c_clause(),State}.
%% This is a case/receive clause where the is only one pattern.
comp_clause([Pat|Body], Env0, L, St0) ->
{Cp,Pvs,St1} = pattern(Pat, L, St0),
Env1 = add_vbindings(Pvs, Env0),
{Cg,Cb,St2} = comp_clause_body(Body, Env1, L, St1),
{ann_c_clause([L], [Cp], Cg, Cb),St2}.
comp_clause_body([['when'|Guard]|Body], Env, L, St0) ->
{Cg,St1} = comp_guard(Guard, Env, L, St0),
{Cb,St2} = comp_body(Body, Env, L, St1),
{Cg,Cb,St2};
comp_clause_body(Body, Env, L, St0) ->
{Cb,St1} = comp_body(Body, Env, L, St0),
{c_atom(true),Cb,St1}.
%% comp_try(Body, Env, Line, State) -> {c_try(),State}.
%% Compile a try. We know that case is optional but must have at
%% least one of catch or after. Complicated by the behaviour of the
%% after which means we split try with all parts into two try's.
comp_try([E|Body], Env, L, St) ->
%% Separate try body into separate bits, none if not there.
Case = tag_tail(Body, 'case'),
Catch = tag_tail(Body, 'catch'),
After = tag_tail(Body, 'after'),
comp_try(E, Case, Catch, After, Env, L, St). %Now build the bugger
%% comp_try(Exp, Case, Catch, After, Env, L, St) -> {c_try(),State}.
comp_try(E, Case, [], [], Env, L, St0) ->
%% No catch or after - (try E [(case ...)])
%% This is compiler generated.
{Ce,St1} = comp_expr(E, Env, L, St0),
{Cv,Cc,St2} = try_case(Case, Env, L, St1),
{[_,Val,Info]=Evs,St3} = new_c_vars(3, L, St2), %Tag, Value, Info
After = raise_primop([Info,Val], L, St2),
Ann = line_file_anno(L, St3),
{ann_c_try(Ann, Ce, [Cv], Cc, Evs, After),St3};
comp_try(E, Case, Catch, [], Env, L, St0) ->
%% No after - (try E [(case ...)] (catch ...))
{Ce,St1} = comp_expr(E, Env, L, St0),
{Cv,Cc,St2} = try_case(Case, Env, L, St1),
{Evs,Ecs,St3} = try_exception(Catch, Env, L, St2),
Ann = line_file_anno(L, St3),
{ann_c_try(Ann, Ce, [Cv], Cc, Evs, Ecs),St3};
comp_try(E, [], [], After, Env, L, St0) ->
%% Just after - (try E (after ...))
{Ce,St1} = comp_expr(E, Env, L, St0),
{Cv,St2} = new_c_var(L, St1),
{Ca,St3} = comp_body(After, Env, L, St2),
Cb = ann_c_seq([L], Ca, Cv),
{Evs,Ecs,St4} = try_after(After, Env, L, St3),
Ann = line_file_anno(L, St4),
{ann_c_try(Ann, Ce, [Cv], Cb, Evs, Ecs),St4};
comp_try(E, Case, Catch, After, Env, L, St) ->
%% Both catch and after - (try E [(case ...)] (catch ...) (after ...))
%% The case where all options are given.
Try = ['try',E,['case'|Case],['catch'|Catch]],
comp_try(Try, [], [], After, Env, L, St).
%% try_case(CaseClauses, Env, Line, State) -> {Var,c_case()|c_var(),State}.
%% Case is optional, no case just returns value.
try_case([], _, L, St0) -> %No case, just return value
{Cv,St1} = new_c_var(L, St0),
{Cv,Cv,St1};
try_case(Cls, Env, L, St0) ->
{Cv,St1} = new_c_var(L, St0),
{Ccs,St2} = case_clauses(Cls, Env, L, St1),
Cf = try_case_fail(L, St2),
{Cv,ann_c_case([L], Cv, Ccs ++ [Cf]),St2}.
try_case_fail(L, St) ->
Cv = c_var(omega),
fail_clause([Cv], c_tuple([c_atom(try_clause),Cv]), [], L, St).
%% try_exception(CatchClauses, Env, L, State) -> {Vars,c_case(),State}.
try_exception(Cls, Env, L, St0) ->
%% Note that Tag is not needed for rethrow - it is already in Info.
{Cvs,St1} = new_c_vars(3, L, St0), %Tag, Value, Info
{Ccs,St2} = case_clauses(Cls, Env, L, St1),
[_,Val,Info] = Cvs,
Arg = c_tuple(Cvs),
Fc = ann_c_clause(comp_gen_anno(L, St2), %It is compiler generated
[Arg], raise_primop([Info,Val], L, St2)),
Excp = ann_c_case([L], Arg, Ccs ++ [Fc]),
{Cvs,Excp,St2}.
%% try_after(AfterBody, Env, L, State) -> {Vars,After,State}.
try_after(B, Env, L, St0) ->
%% Note that Tag is not needed for rethrow - it is already in Info.
{[_,Val,Info]=Cvs,St1} = new_c_vars(3, L, St0), %Tag, Value, Info
{Cb,St2} = comp_body(B, Env, L, St1),
After = ann_c_seq([L], Cb, raise_primop([Info,Val], L, St2)),
{Cvs,After,St2}.
raise_primop(Args, L, _) ->
ann_c_primop([L], c_atom(raise), Args).
tag_tail([[Tag|Tail]|_], Tag) -> Tail;
tag_tail([_|Try], Tag) -> tag_tail(Try, Tag);
tag_tail([], _) -> [].
%% comp_funcall(Call, Args, Env, Line, State) -> {Core,State}.
%% Special case if Call is directly lambda or match-lambda, convert
%% to a let. Might be useful in macros.
comp_funcall([lambda,Las|Body]=F, As, Env, L, St) ->
if length(Las) == length(As) -> %Check right number of args
%% Convert into a let. Would like to sequentialise eval of
%% args here but leave that to let.
Vbs = zipwith(fun (V, E) -> [V,E] end, Las, As),
comp_let(Vbs, Body, Env, L, St);
true -> %Catch arg mismatch at runtime
comp_funcall_1(F, As, Env, L, St)
end;
comp_funcall(['match-lambda'|Cls]=F, As, Env, L, St0) ->
case match_lambda_arity(Cls) == length(As) of
true ->
%% Expand comp_let as we need to special case body.
{Cf,St1} = comp_match_lambda(Cls, Env, L, St0),
Cvs = fun_vars(Cf),
Cb = fun_body(Cf),
Efun = fun (E, St) -> comp_expr(E, Env, L, St) end,
{Ces,St2} = mapfoldl(Efun, St1, As),
{ann_c_let([L], Cvs, ann_c_values([L], Ces), Cb),St2};
false -> %Catch arg mismatch at runtime
comp_funcall_1(F, As, Env, L, St0)
end;
comp_funcall(F, As, Env, L, St0) ->
comp_funcall_1(F, As, Env, L, St0). %Naively just do it.
comp_funcall_1(F, As, Env, L, St0) ->
App = fun ([Cf|Cas], _, Li, St) ->
Ann = line_file_anno(Li, St),
{ann_c_apply(Ann, Cf, Cas),St}
end,
comp_args([F|As], App, Env, L, St0).
%% comp_binary(Segs, Env, Line, State) -> {CbinaryExpr,State}.
%% Compile a binary.
comp_binary(Segs, Env, L, St0) ->
Vsps = get_bitsegs(Segs),
comp_bitsegs(Vsps, Env, L, St0).
get_bitsegs(Segs) ->
foldr(fun (Seg, Vs) -> get_bitseg(Seg, Vs) end, [], Segs).
%% get_bitseg(Bitseg, ValSpecs) -> ValSpecs.
%% A bitseg is either an atomic value, a list of value and specs, or
%% a string. Note that this function can prepend a list of valspecs.
get_bitseg([Val|Specs]=F, Vsps) ->
case is_integer_list(F) of %Is bitseg a string?
true -> %A string
{Sz,Ty} = get_bitspecs([]),
foldr(fun (V, Vs) -> [{V,Sz,Ty}|Vs] end, Vsps, F);
false -> %A value and spec
{Sz,Ty} = get_bitspecs(Specs),
case is_integer_list(Val) of %Is val a string?
true -> foldr(fun (V, Vs) -> [{V,Sz,Ty}|Vs] end, Vsps, Val);
false -> [{Val,Sz,Ty}|Vsps] %The default
end
end;
get_bitseg(Val, Vsps) ->
{Sz,Ty} = get_bitspecs([]),
[{Val,Sz,Ty}|Vsps].
get_bitspecs(Ss) ->
{ok,Sz,Ty} = lfe_bits:get_bitspecs(Ss),
{Sz,Ty}.
is_integer_list([I|Is]) when is_integer(I) ->
is_integer_list(Is);
is_integer_list([]) -> true;
is_integer_list(_) -> false.
%% comp_bitsegs(ValSpecs, Env, Line, State) -> {CBitSegs,State}.
%% Compile the bitsegements sequentialising them with simple_seq.
comp_bitsegs(Vsps, Env, L, St) ->
comp_bitsegs(Vsps, [], Env, L, St).
comp_bitsegs([Vsp|Segs], Csegs, Env, L, St0) ->
{Cval,Csize,Un,Ty,Fs,St1} = comp_bitseg(Vsp, Env, L, St0),
%% Sequentialise Val and Size if necessary, then do rest
Next = fun ([Cv,Csz], En, Li, St) ->
Cs = c_bitstr(Cv, Csz, Un, Ty, Fs),
comp_bitsegs(Segs, [Cs|Csegs], En, Li, St)
end,
simple_seq([Cval,Csize], Next, Env, L, St1);
comp_bitsegs([], Csegs, _, L, St) ->
{ann_c_binary([L], reverse(Csegs)),St}.
%% comp_bitseg(ValSpec, Env, Line, State) -> {Cval,Csize,Unit,Type,Fs,State}.
%% Need to handle some special cases.
comp_bitseg({Val,_,{Ty,_,Si,En}}, Env, L, St0)
when Ty =:= utf8 ; Ty =:= utf16 ; Ty =:= utf32 ->
%% Special case utf types.
{Cval,St1} = comp_expr(Val, Env, L, St0),
Undef = c_atom(undefined),
{Cval,Undef,Undef,c_atom(Ty),c_lit([Si,En]),St1};
comp_bitseg({Val,all,{binary,_,_,_}=Ty}, Env, L, St) ->
comp_bitseg({Val,?Q(all),Ty}, Env, L, St);
comp_bitseg({Val,Sz,{Ty,Un,Si,En}}, Env, L, St0) ->
{Cval,St1} = comp_expr(Val, Env, L, St0),
{Csize,St2} = comp_expr(Sz, Env, L, St1),
{Cval,Csize,c_int(Un),c_atom(Ty),c_lit([Si,En]),St2}.
%% comp_map(Args, Env, Line, State) -> {Core,State}.
%% comp_set_map(Map, Args, Line, State) -> {Core,State}.
%% comp_upd_map(Map, Args, Line, State) -> {Core,State}.
-ifdef(HAS_MAPS).
%% There is no need to check for HAS_FULL_KEYS here as the linter will
%% catch the limited code. The setting/updating maps operations need
%% to be wrapped with an 'if' which does an explicit test that the map
%% argument is a map. This does not have exactly the same structure
%% and annotations as a "normal" 'if'.
comp_map(Args, Env, Line, St) ->
Mapper = fun (Cas, _, L, St) ->
Cpairs = comp_map_pairs(Cas, assoc, L),
{ann_c_map([L], c_lit(#{}), Cpairs),St}
end,
comp_args(Args, Mapper, Env, Line, St).
comp_set_map(Map, Args, Env, Line, St) ->
comp_modify_map(Map, Args, assoc, Env, Line, St).
comp_upd_map(Map, Args, Env, Line, St) ->
comp_modify_map(Map, Args, exact, Env, Line, St).
comp_modify_map(Map, Args, Key, Env, Line, St0) ->
%% Evaluate map, keys and values and build modify form.
Mapper = fun ([Cm|Cas], E, L, St) ->
Cpairs = comp_map_pairs(Cas, Key, L),
comp_map_test(Cm, Cpairs, E, L, St)
end,
comp_args([Map|Args], Mapper, Env, Line, St0).
comp_map_test(Cm, Cpairs, _, L, St) ->
%% Build map type tester.
Ann = line_file_anno(L, St),
Cmap = ann_c_clause([compiler_generated|Ann], [],
ann_c_call(Ann, ann_c_atom(Ann, erlang),
ann_c_atom(Ann, is_map), [Cm]),
ann_c_map(Ann, Cm, Cpairs)),
Cfail = map_fail(Cm, L, St),
{ann_c_case(Ann, ann_c_values(Ann, []), [Cmap,Cfail]),St}.
map_fail(_Map, L, St) ->
Fann = [{eval_failure,badmap}],
fail_clause([], c_atom(badmap), Fann, L, St).
%% fail_clause([], c_tuple([c_atom(badmap),Map]), Fann, L, St).
comp_map_pairs([K,V|Ps], Op, L) ->
[ann_c_map_pair([L], c_lit(Op), K, V)|comp_map_pairs(Ps, Op, L)];
comp_map_pairs([], _, _) -> [].
-else.
%% These are just dummy functions which will never be called as
%% lfe_lint will catch these forms.
comp_map(_, _, _, St) -> {c_lit(map),St}.
comp_set_map(_, _, _, _, St) -> {c_lit(map),St}.
comp_upd_map(_, _, _, _, St) -> {c_lit(map),St}.
-endif.
%% comp_guard(GuardTests, Env, Line, State) -> {CoreGuard,State}.
%% Can compile much of the guard as an expression but must wrap it
%% all in a try, which we do here. This try handles exceptions in the
%% guard and has a very rigid structure.
comp_guard([], _, _, St) -> {c_atom(true),St}; %The empty guard
comp_guard(Gts, Env, L, St0) ->
{Ce,St1} = comp_guard_tests(Gts, Env, L, St0), %Guard expression
%% Can hard code the rest!
Cv = c_var('Try'),
Evs = [c_var('T'),c_var('R')], %Why only two?
False = c_atom(false), %Exception returns false
Ann = line_file_anno(L, St1),
{ann_c_try(Ann, Ce, [Cv], Cv, Evs, False),St1}.
%% comp_guard_tests(GuardTests, Env, Line, State) -> {CoreTest,State}.
%% Compile a guard test, making sure it returns a boolean value. We
%% do this in a naive way by always explicitly comparing the result
%% to 'true' and letting the optimiser clean this up. Ignore errors.
comp_guard_tests(Gts, Env, Line, St0) ->
{Gas,St1} = mapfoldl(fun (Gt, St) -> comp_guard_test(Gt, Env, Line, St) end,
St0, Gts),
Ands = fun guard_ands/4,
simple_seq(Gas, Ands, Env, Line, St1).
guard_ands([Ga], _, _, St) -> {Ga,St};
guard_ands([G1,G2], _, Line, St) ->
{ann_c_call([Line], c_atom(erlang), c_atom('and') , [G1,G2]), St};
guard_ands([G1,G2|Gas], Env, Line, St0) ->
{Cv,St1} = new_c_var(Line, St0),
{Gr,St2} = guard_ands([Cv|Gas], Env, Line, St1),
And = ann_c_call([Line], c_atom(erlang), c_atom('and'), [G1,G2]),
{ann_c_let([Line], [Cv], And, Gr),St2}.
%% comp_guard_test(Test, Env, Line, State) -> {CoreTest,State}.
%% Compile one test. We try to avoid generating an unnecessary true
%% test by checking the test and only adding one when we know the
%% test won't automatically return a boolean value.
comp_guard_test([quote,Bool], _, _, St) when is_boolean(Bool) ->
{c_atom(Bool),St}; %A small optimisation
comp_guard_test([call,[quote,erlang],[quote,Op]|Args]=Test, Env, L, St) ->
comp_guard_test_1(Test, Op, Args, Env, L, St);
comp_guard_test([Op|Args]=Test, Env, L, St) ->
comp_guard_test_1(Test, Op, Args, Env, L, St);
comp_guard_test(Symb, _, L, St) when is_atom(Symb) ->
Ann = comp_gen_anno(L, St),
{ann_c_call(Ann, c_atom(erlang), c_atom('=:='), [c_var(Symb),c_atom(true)]),
St};
comp_guard_test(_, _, _, St) ->
%% Everything else always will always fail.
{c_atom(false),St}.
comp_guard_test_1(Test, Op, Args, Env, L, St0) ->
Ar = length(Args),
%% Check if this is a boolean test, else add a boolean test.
case erl_internal:bool_op(Op, Ar) orelse
erl_internal:comp_op(Op, Ar) orelse
erl_internal:type_test(Op, Ar) of
true -> %It's already boolean
comp_gexpr(Test, Env, L, St0);
false -> %No it's not, then make it one
Call = fun (Cas, _, Li, St) ->
Ann = comp_gen_anno(Li, St),
{ann_c_call(Ann, c_atom(erlang), c_atom('=:='), Cas),
St}
end,
comp_gargs([Test,?Q(true)], Call, Env, L, St0)
end.
%% comp_gexpr(Expr, Env, Line, State) -> {CoreExpr,State}.
%% Handle the Core data special forms.
comp_gexpr([quote,E], _, _, St) -> {comp_lit(E),St};
comp_gexpr([cons,H,T], Env, L, St) ->
Cons = fun ([Ch,Ct], _, _, St) -> {c_cons(Ch, Ct),St} end,
comp_gargs([H,T], Cons, Env, L, St);
comp_gexpr([car,E], Env, L, St) -> %Provide lisp names
comp_gexpr([hd,E], Env, L, St);
comp_gexpr([cdr,E], Env, L, St) ->
comp_gexpr([tl,E], Env, L, St);
comp_gexpr([list|Es], Env, L, St) ->
List = fun (Ces, _, _, St) ->
{foldr(fun (E, T) -> c_cons(E, T) end, c_nil(), Ces),St}
end,
comp_gargs(Es, List, Env, L, St);
comp_gexpr([tuple|As], Env, L, St) ->
comp_gargs(As, fun (Args, _, _, St) -> {c_tuple(Args),St} end, Env, L, St);
comp_gexpr([binary|Segs], Env, L, St) ->
comp_binary(Segs, Env, L, St); %And bitstring as well
comp_gexpr([map|As], Env, L, St) ->
comp_map(As, Env, L, St);
comp_gexpr(['mset',Map|As], Env, L, St) ->
comp_set_map(Map, As, Env, L, St);
comp_gexpr(['mupd',Map|As], Env, L, St) ->
comp_upd_map(Map, As, Env, L, St);
comp_gexpr(['map-set',Map|As], Env, L, St) ->
comp_gexpr(['mset',Map|As], Env, L, St);
comp_gexpr(['map-update',Map|As], Env, L, St) ->
comp_gexpr(['mupd',Map|As], Env, L, St);
%% Handle the Core closure special forms.
%% (let-syntax ...) should never be seen here!
%% Handle the Core control special forms.
comp_gexpr(['progn'|Body], Env, L, St) ->
comp_guard_tests(Body, Env, L, St);
comp_gexpr(['if'|Body], Env, L, St) ->
comp_gif(Body, Env, L, St);
comp_gexpr([call,[quote,erlang],[quote,Fun]|As], Env, L, St) ->
comp_gexpr([Fun|As], Env, L, St); %Pass the buck
%% Finally the general case.
comp_gexpr([Fun|As], Env, L, St) ->
Call = fun (Cas, En, Li, Sta) ->
Ar = length(Cas),
{yes,M,F} = get_gbinding(Fun, Ar, En),
Ann = line_file_anno(Li, Sta),
{ann_c_call(Ann, c_atom(M), c_atom(F), Cas),Sta}
end,
comp_gargs(As, Call, Env, L, St);
comp_gexpr(Symb, _, _, St) when is_atom(Symb) ->
{c_var(Symb),St};
%% Everything is a literal constant (nil, tuples, numbers, binaries).
comp_gexpr(Const, _, _, St) ->
{comp_lit(Const),St}.
%% comp_gargs(Args, CallFun, Env, Line, State) -> {Call,State}.
comp_gargs(As, Call, Env, L, St0) ->
{Cas,St1} = mapfoldl(fun (A, St) -> comp_gexpr(A, Env, L, St) end, St0, As),
simple_seq(Cas, Call, Env, L, St1).
%% comp_gif(IfBody, Env, Line, State) -> {c_case(),State}.
%% Compile in if form to a case testing the Test expression.
comp_gif([Test,True], Env, L, St) ->
comp_gif(Test, True, ?Q(false), Env, L, St);
comp_gif([Test,True,False], Env, L, St) ->
comp_gif(Test, True, False, Env, L, St).
comp_gif(Te, Tr, Fa, Env, L, St0) ->
{Cte,St1} = comp_gexpr(Te, Env, L, St0), %Test expression
{Ctr,St2} = comp_gexpr(Tr, Env, L, St1), %True test
{Cfa,St3} = comp_gexpr(Fa, Env, L, St2), %False test
True = c_atom(true),
False = c_atom(false),
Omega = c_var(omega),
Ctrue = ann_c_clause([L], [True], Ctr),
Cfalse = ann_c_clause([L], [False], Cfa),
Cfail = ann_c_clause(comp_gen_anno(L, St3), [Omega], Omega),
{ann_c_case([L], Cte, [Ctrue,Cfalse,Cfail]),St3}.
%% This produces code which is harder to optimise, strangely enough.
%% comp_gif(Te, Tr, Fa, Env, L, St0) ->
%% {Cte,St1} = comp_gexpr(Te, Env, L, St0), %Test expression
%% {Ctr,St2} = comp_gexpr(Tr, Env, L, St1), %True expression
%% {Cfa,St3} = comp_gexpr(Fa, Env, L, St2), %False expression
%% If = fun ([Ctest], _, _, St) ->
%% True = c_atom(true),
%% False = c_atom(false),
%% Omega = c_var(omega),
%% Ctrue = ann_c_clause([L], [True], Ctr),
%% Cfalse = ann_c_clause([L], [False], Cfa),
%% Cfail = ann_c_clause(comp_gen_anno(L, St3), [Omega], Omega),
%% {ann_c_case([L], Ctest, [Ctrue,Cfalse,Cfail]),St}
%% end,
%% simple_seq([Cte], If, Env, L, St3).
%% comp_lit(Value) -> LitExpr.
%% Make a literal expression from an Erlang value. Try to make it as
%% literal as possible. This function will fail if the value is not
%% expressable as a literal (for instance, a pid).
comp_lit([H|T]) ->
Ch = comp_lit(H),
Ct = comp_lit(T),
%% c_cons is smart and can handle head and tail both literals.
c_cons(Ch, Ct);
comp_lit([]) -> c_nil();
comp_lit(T) when is_tuple(T) ->
Es = comp_lit_list(tuple_to_list(T)),
%% c_tuple is smart and can handle a list of literals.
c_tuple(Es);
comp_lit(A) when is_atom(A) -> c_atom(A);
comp_lit(I) when is_integer(I) -> c_int(I);
comp_lit(F) when is_float(F) -> c_float(F);
comp_lit(Bin) when is_bitstring(Bin) ->
Bits = comp_lit_bitsegs(Bin),
ann_c_binary([], Bits);
comp_lit(Map) when ?IS_MAP(Map) ->
comp_lit_map(Map).
comp_lit_list(Vals) -> [ comp_lit(V) || V <- Vals ].
is_lit_list(Es) -> all(fun (E) -> is_literal(E) end, Es).
comp_lit_bitsegs(<<B:8,Bits/bitstring>>) -> %Next byte
[c_byte_bitseg(B, 8)|comp_lit_bitsegs(Bits)];
comp_lit_bitsegs(<<>>) -> []; %Even bytes
comp_lit_bitsegs(Bits) -> %Size < 8
N = bit_size(Bits),
<<B:N>> = Bits,
[c_byte_bitseg(B, N)].
c_byte_bitseg(B, Sz) ->
c_bitstr(c_lit(B), c_int(Sz), c_int(1), c_atom(integer),
c_lit([unsigned,big])).
-ifdef(HAS_MAPS).
comp_lit_map(Map) ->
Pairs = comp_lit_map_pairs(maps:to_list(Map)),
ann_c_map([], c_lit(#{}), Pairs).
comp_lit_map_pairs([{K,V}|Ps]) ->
[ann_c_map_pair([], c_lit(assoc), comp_lit(K), comp_lit(V))|
comp_lit_map_pairs(Ps)];
comp_lit_map_pairs([]) -> [].
-else.
comp_lit_map(_) -> c_lit(map).
-endif.
%% pattern(Pattern, Line, Status) -> {CorePat,PatVars,State}.
%% Compile a pattern into a Core term. Handle quoted sexprs here
%% especially for symbols which then become variables instead of
%% atoms.
pattern(Pat, L, St) -> pattern(Pat, L, [], St).
pattern([quote,E], _, Vs, St) -> {pat_lit(E),Vs,St};
pattern(['=',P1,P2], L, Vs0, St0) ->
%% Core can only alias against a variable so there is wotk to do!
{Cp1,Vs1,St1} = pattern(P1, L, Vs0, St0),
{Cp2,Vs2,St2} = pattern(P2, L, Vs0, St1),
Cp = pat_alias(Cp1, Cp2),
{Cp,union(Vs1, Vs2),St2};
pattern([cons,H,T], L, Vs0, St0) ->
{Ch,Vs1,St1} = pattern(H, L, Vs0, St0),
{Ct,Vs2,St2} = pattern(T, L, Vs1, St1),
{c_cons(Ch, Ct),Vs2,St2};
pattern([list|Ps], L, Vs, St) ->
pat_list(Ps, L, Vs, St);
pattern([tuple|Ps], L, Vs0, St0) ->
{Cps,{Vs1,St1}} = mapfoldl(fun (P, {Vsa,Sta}) ->
{Cp,Vsb,Stb} = pattern(P, L, Vsa, Sta),
{Cp,{Vsb,Stb}}
end, {Vs0,St0}, Ps),
{c_tuple(Cps),Vs1,St1};
pattern([binary|Segs], L, Vs, St) ->
pat_binary(Segs, L, Vs, St);
pattern([map|As], L, Vs, St) ->
pat_map(As, L, Vs, St);
%% This allows us to use ++ macro in patterns.
%% pattern([call,[quote,erlang],[quote,'++'],A1,A2], L, Vs, St) ->
%% Pat = foldr(fun (H, T) -> [cons,H,T] end, A2, A1),
%% pattern(Pat, L, Vs, St);
%% Compile old no contructor list forms.
pattern([H|T], L, Vs0, St0) ->
{Ch,Vs1,St1} = pattern(H, L, Vs0, St0),
{Ct,Vs2,St2} = pattern(T, L, Vs1, St1),
{c_cons(Ch, Ct),Vs2,St2};
pattern([], _, Vs, St) -> {c_nil(),Vs,St};
%% Literals.
pattern(Bin, _, Vs, St) when is_bitstring(Bin) ->
{pat_lit(Bin),Vs,St};
pattern(Tup, _, Vs, St) when is_tuple(Tup) ->
{pat_lit(Tup),Vs,St};
pattern(Symb, L, Vs, St) when is_atom(Symb) ->
pat_symb(Symb, L, Vs, St); %Variable
pattern(Numb, _, Vs, St) when is_number(Numb) -> {c_lit(Numb),Vs,St}.
pat_list([P|Ps], L, Vs0, St0) ->
{Cp,Vs1,St1} = pattern(P, L, Vs0, St0),
{Cps,Vs2,St2} = pat_list(Ps, L, Vs1, St1),
{c_cons(Cp, Cps),Vs2,St2};
pat_list([], _, Vs, St) -> {c_nil(),Vs,St}.
pat_symb('_', L, Vs, St0) -> %Don't care variable.
{Cv,St1} = new_c_var(L, St0),
{Cv,Vs,St1}; %Not added to variables
pat_symb(Symb, _, Vs, St) ->
{c_var(Symb),add_element(Symb, Vs),St}.
%% pat_alias(CorePat, CorePat) -> AliasPat.
%% Normalise aliases. This has been taken from v3_core.erl in the
%% erlang compiler. This is more complicated in core as we can
%% sometimes get structures as "literal". Trap bad aliases by
%% throwing 'nomatch' as these should have been caught in lfe_lint.
pat_alias(Cp1, Cp2) ->
%% io:format("pa: ~p\n", [{Cp1,Cp2}]),
case {cerl:type(Cp1),cerl:type(Cp2)} of
{var,_} -> c_alias(Cp1, Cp2);
{_,var} -> c_alias(Cp2, Cp1);
{cons,literal} ->
pat_alias_cons(Cp1, Cp2);
{literal,cons} ->
pat_alias_cons(Cp2, Cp1);
{cons,cons} ->
c_cons(pat_alias(cons_hd(Cp1), cons_hd(Cp2)),
pat_alias(cons_tl(Cp1), cons_tl(Cp2)));
{tuple,literal} ->
pat_alias_tuple(Cp1, Cp2);
{literal,tuple} ->
pat_alias_tuple(Cp2, Cp1);
{tuple,tuple} ->
c_tuple(pat_alias_list(tuple_es(Cp1), tuple_es(Cp2)));
{alias,alias} ->
Cv1 = alias_var(Cp1),
Cv2 = alias_var(Cp2),
if Cv1 =:= Cv2 ->
pat_alias(alias_pat(Cp1), alias_pat(Cp2));
true ->
c_alias(Cv1, c_alias(Cv2, pat_alias(alias_pat(Cp1),
alias_pat(Cp2))))
end;
{alias,_} ->
c_alias(alias_var(Cp1), pat_alias(alias_pat(Cp1), Cp2));
{_,alias} ->
c_alias(alias_var(Cp2), pat_alias(Cp1, alias_pat(Cp2)));
_ ->
%% Check that they are the same except for annotation.
case {set_ann(Cp1, []),set_ann(Cp2, [])} of
{P,P} -> Cp1;
_ -> throw({nomatch,Cp1,Cp2})
end
end.
pat_alias_cons(Cc, Cl) ->
case lit_val(Cl) of
[H|T] ->
%% Must be sure to build a #c_cons{} here
pat_alias(Cc, c_cons_skel(c_lit(H), c_lit(T)));
_ -> throw(nomatch)
end.
pat_alias_tuple(Ct, Cl) ->
case lit_val(Cl) of
Tup when is_tuple(Tup) ->
update_c_tuple(Ct, pat_alias_list(tuple_es(Ct), data_es(Cl)));
_ -> throw(nomatch)
end.
%% pat_alias_list([A1], [A2]) -> [A].
pat_alias_list([A1|A1s], [A2|A2s]) ->
[pat_alias(A1, A2)|pat_alias_list(A1s, A2s)];
pat_alias_list([], []) -> [];
pat_alias_list(_, _) -> throw(nomatch).
%% pat_binary(Segs, Line, PatVars, State) -> {c_binary(),PatVars,State}.
pat_binary(Segs, L, Vs0, St0) ->
Vsps = get_bitsegs(Segs),
{Csegs,Vs1,St1} = pat_bitsegs(Vsps, L, Vs0, St0),
{ann_c_binary([L], Csegs),Vs1,St1}.
%% pat_bitsegs(Segs, Line, PatVars, State) -> {CBitsegs,PatVars,State}.
pat_bitsegs(Segs, L, Vs0, St0) ->
{Csegs,{Vs1,St1}} =
mapfoldl(fun (S, {Vsa,Sta}) ->
{Cs,Vsb,Stb} = pat_bitseg(S, L, Vsa, Sta),
{Cs,{Vsb,Stb}}
end, {Vs0,St0}, Segs),
{Csegs,Vs1,St1}.
%% pat_bitseg(Seg, Line, PatVars, State) -> {c_bitstr(),PatVars,State}.
%% ??? Should noenv be lfe_env:new() instead ???
%% ??? We know its correct so why worry? ???
pat_bitseg({Pat,_,{Ty,_,Si,En}}, L, Vs0, St0)
when Ty =:= utf8 ; Ty =:= utf16 ; Ty =:= utf32 ->
%% Special case utf types.
{Cpat,Vs1,St1} = pattern(Pat, L, Vs0, St0),
Undef = c_atom(undefined),
{c_bitstr(Cpat,Undef,Undef,c_atom(Ty),c_lit([Si,En])),Vs1,St1};
pat_bitseg({Pat,all,{binary,_,_,_}=Ty}, L, Vs, St) ->
pat_bitseg({Pat,?Q(all),Ty}, L, Vs, St);
pat_bitseg({Pat,Sz,{Ty,Un,Si,En}}, L, Vs0, St0) ->
{Cpat,Vs1,St1} = pattern(Pat, L, Vs0, St0),
{Csize,St2} = comp_expr(Sz, noenv, L, St1),
{c_bitstr(Cpat, Csize, c_int(Un), c_atom(Ty), c_lit([Si,En])),Vs1,St2}.
-ifdef(HAS_MAPS).
%% pat_map(Args, Line, PatVars, State) -> {c_map(),PatVars,State}.
pat_map(Args, L, Vs0, St0) ->
{Pairs,Vs1,St1} = pat_map_pairs(Args, L, Vs0, St0),
%% Build #c_map{} then fill it in.
Map = ann_c_map_pattern([L], Pairs), %Must us this for a pattern
{Map,Vs1,St1}.
pat_map_pairs([K,V|As], L, Vs0, St0) ->
Ck = pat_map_key(K),
{Cv,Vs1,St1} = pattern(V, L, Vs0, St0),
{Cps,Vs2,St2} = pat_map_pairs(As, L, Vs1, St1),
{[ann_c_map_pair([L], c_lit(exact), Ck, Cv)|Cps],
Vs2,St2};
pat_map_pairs([], _, Vs, St) -> {[],Vs,St}.
pat_map_key([quote,L]) -> pat_lit(L);
pat_map_key(L) -> pat_lit(L).
-else.
pat_map(_, _, Vs, St) -> {c_lit(map),Vs,St}.
-endif.
%% pat_lit(Value) -> LitExpr.
%% Make a literal expression from an Erlang value. Make it as literal
%% as is required for a pattern. This function will fail if the value
%% is not expressable as a literal (for instance, a pid).
pat_lit([H|T]) ->
Ch = pat_lit(H),
Ct = pat_lit(T),
%% c_cons is smart and can handle head and tail both literals.
c_cons(Ch, Ct);
pat_lit([]) -> c_nil();
pat_lit(T) when is_tuple(T) ->
Es = pat_lit_list(tuple_to_list(T)),
%% c_tuple is smart and can handle a list of literals.
c_tuple(Es);
pat_lit(A) when is_atom(A) -> c_atom(A);
pat_lit(I) when is_integer(I) -> c_int(I);
pat_lit(F) when is_float(F) -> c_float(F);
pat_lit(Bin) when is_bitstring(Bin) ->
Bits = pat_lit_bitsegs(Bin),
ann_c_binary([], Bits);
pat_lit(Map) when ?IS_MAP(Map) ->
pat_lit_map(Map).
pat_lit_list(Vals) -> [ pat_lit(V) || V <- Vals ].
pat_lit_bitsegs(<<B:8,Bits/bitstring>>) -> %Next byte
[c_byte_bitseg(B, 8)|pat_lit_bitsegs(Bits)];
pat_lit_bitsegs(<<>>) -> []; %Even bytes
pat_lit_bitsegs(Bits) -> %Size < 8
N = bit_size(Bits),
<<B:N>> = Bits,
[c_byte_bitseg(B, N)].
-ifdef(HAS_MAPS).
pat_lit_map(Map) ->
Pairs = pat_lit_map_pairs(maps:to_list(Map)),
ann_c_map([], c_lit(#{}), Pairs).
pat_lit_map_pairs([{K,V}|Ps]) ->
[ann_c_map_pair([], c_lit(assoc), pat_lit(K), pat_lit(V))|
pat_lit_map_pairs(Ps)];
pat_lit_map_pairs([]) -> [].
-else.
pat_lit_map(_) -> c_lit(map).
-endif.
%% line_file_anno(Line, State) -> Anno.
%% Make annotation with line number and file.
line_file_anno(L, St) ->
[L,{file,St#cg.file}].
%% comp_gen_anno(Line, State) -> Anno.
%% Make annotation with line number and compiler_generated.
comp_gen_anno(L, _) ->
[L,compiler_generated].
%% new_symb(State) -> {Symbol,State}.
%% Create a hopefully new unused symbol.
%% new_symb(St) ->
%% C = St#cg.vc,
%% {list_to_atom("|=" ++ integer_to_list(C) ++ "=|"),St#cg{vc=C+1}}.
new_fun_name(Pre, St) ->
C = St#cg.fc,
{list_to_atom("'" ++ Pre ++ "~" ++ integer_to_list(C)),St#cg{fc=C+1}}.
%% new_c_var(Line, State) -> {c_var(),State}.
%% Create a hopefully new core variable.
new_c_var(_, St) ->
C = St#cg.vc,
Name = list_to_atom(integer_to_list(C)),
{c_var(Name),St#cg{vc=C+1}}.
new_c_vars(N, L, St) -> new_c_vars(N, L, St, []).
new_c_vars(N, L, St0, Vs) when N > 0 ->
{V,St1} = new_c_var(L, St0),
new_c_vars(N-1, L, St1, [V|Vs]);
new_c_vars(0, _, St, Vs) -> {Vs,St}.
add_vbindings(Vs, Env) ->
foldl(fun (V, E) -> add_vbinding(V, dummy, E) end, Env, Vs).
%% safe_fetch(Key, Dict, Default) -> Value.
safe_fetch(Key, D, Def) ->
case find(Key, D) of
{ok,Val} -> Val;
error -> Def
end.
%% is_simple(CoreExp) -> bool().
%% Test if CoreExp is simple, i.e. just constructs terms.
is_simple(Ce) ->
case cerl:type(Ce) of
var -> true;
literal -> true;
cons ->
is_simple(cons_hd(Ce)) andalso is_simple(cons_tl(Ce));
tuple ->
is_simple_list(tuple_es(Ce));
binary ->
is_simple_bin(binary_segments(Ce));
_ -> false
end.
is_simple_list(Es) -> all(fun is_simple/1, Es).
is_simple_bin(Ss) ->
all(fun (Seg) ->
is_simple(bitstr_val(Seg)) andalso is_simple(bitstr_size(Seg))
end, Ss).
%% Constructor functions for building Core forms. These now just call
%% functions in cerl.
c_module(Name, Exp, Defs) ->
cerl:c_module(Name, Exp, Defs).
update_c_module(Mod, Name, Exp, Atts, Defs) ->
cerl:update_c_module(Mod, Name, Exp, Atts, Defs).
ann_c_call(Ann, M, F, As) ->
cerl:ann_c_call(Ann, M, F, As).
ann_c_try(Ann, E, Vs, B, Evs, H) ->
cerl:ann_c_try(Ann, E, Vs, B, Evs, H).
ann_c_fun(Ann, Vs, B) ->
cerl:ann_c_fun(Ann, Vs, B).
fun_vars(Fun) -> cerl:fun_vars(Fun).
fun_body(Fun) -> cerl:fun_body(Fun).
ann_c_primop(Ann, N, As) ->
cerl:ann_c_primop(Ann, N, As).
ann_c_let(Ann, Vs, A, B) ->
cerl:ann_c_let(Ann, Vs, A, B).
ann_c_letrec(Ann, Defs, B) ->
cerl:ann_c_letrec(Ann, Defs, B).
ann_c_catch(Ann, Body) ->
cerl:ann_c_catch(Ann, Body).
ann_c_receive(Ann, Cs, To, A) ->
cerl:ann_c_receive(Ann, Cs, To, A).
ann_c_case(Ann, E, Cs) ->
cerl:ann_c_case(Ann, E, Cs).
ann_c_clause(Ann, Ps, B) -> %Default true guard
cerl:ann_c_clause(Ann, Ps, B).
ann_c_clause(Ann, Ps, G, B) ->
cerl:ann_c_clause(Ann, Ps, G, B).
ann_c_seq(Ann, A, B) ->
cerl:ann_c_seq(Ann, A, B).
update_c_seq(Node, A, B) ->
cerl:update_c_seq(Node, A, B).
is_c_seq(Node) -> cerl:is_c_seq(Node).
seq_arg(Seq) -> cerl:seq_arg(Seq).
seq_body(Seq) -> cerl:seq_body(Seq).
c_fname(N, A) -> cerl:c_fname(N, A).
ann_c_apply(Ann, Op, As) ->
cerl:ann_c_apply(Ann, Op, As).
ann_c_values(Ann, Vs) -> cerl:ann_c_values(Ann, Vs).
get_ann(Node) -> cerl:get_ann(Node).
set_ann(Node, Ann) -> cerl:set_ann(Node, Ann).
c_alias(Var, Pat) -> cerl:c_alias(Var, Pat).
alias_var(Alias) -> cerl:alias_var(Alias).
alias_pat(Alias) -> cerl:alias_pat(Alias).
c_atom(A) -> cerl:c_atom(A).
ann_c_atom(Ann, A) -> cerl:ann_c_atom(Ann, A).
c_int(I) -> cerl:c_int(I).
c_float(F) -> cerl:c_float(F).
c_nil() -> cerl:c_nil().
ann_c_lit(Ann, Val) -> cerl:ann_abstract(Ann, Val). %Generic literal
c_lit(Val) -> cerl:abstract(Val).
is_literal(Node) -> cerl:is_literal(Node).
lit_val(Lit) -> cerl:concrete(Lit).
data_es(Data) -> cerl:data_es(Data).
c_cons(Hd, Tl) -> cerl:c_cons(Hd, Tl).
c_cons_skel(Hd, Tl) -> cerl:c_cons_skel(Hd, Tl).
cons_hd(Cons) -> cerl:cons_hd(Cons).
cons_tl(Cons) -> cerl:cons_tl(Cons).
c_tuple(Es) -> cerl:c_tuple(Es).
update_c_tuple(Tup, Es) ->
cerl:update_c_tuple(Tup, Es).
tuple_es(Tup) -> cerl:tuple_es(Tup).
c_var(N) -> cerl:c_var(N).
ann_c_binary(Ann, Segs) -> cerl:ann_c_binary(Ann, Segs).
update_c_binary(Bin, Segs) ->
cerl:update_c_binary(Bin, Segs).
binary_segments(Bin) -> cerl:binary_segments(Bin).
c_bitstr(Val, Sz, Un, Ty, Fs) ->
cerl:c_bitstr(Val, Sz, Un, Ty, Fs).
update_c_bitstr(Bit, Val, Sz, Un, Ty, Fs) ->
cerl:update_c_bitstr(Bit, Val, Sz, Un, Ty, Fs).
bitstr_val(Bit) -> cerl:bitstr_val(Bit).
bitstr_size(Bit) -> cerl:bitstr_size(Bit).
bitstr_unit(Bit) -> cerl:bitstr_unit(Bit).
bitstr_type(Bit) -> cerl:bitstr_type(Bit).
bitstr_flags(Bit) -> cerl:bitstr_flags(Bit).
-ifdef(HAS_MAPS).
ann_c_map(Ann, Arg, Ps) ->
cerl:ann_c_map(Ann, Arg, Ps).
%% ann_c_map_pattern(Ann, Pairs) -> Map
%% This function will come first in 18. Until then this is a little
%% tricky as ann_c_map will create a literal if the map pattern is a
%% literal and this is NOT what the compiler wants.
ann_c_map_pattern(Ann, Ps) ->
case erlang:function_exported(cerl, ann_c_map_pattern, 2) of
true ->
cerl:ann_c_map_pattern(Ann, Ps);
false ->
Map0 = ann_c_map(Ann, dummy, Ps),
update_c_map(Map0, c_lit(#{}), Ps)
end.
update_c_map(Map, Arg, Ps) ->
cerl:update_c_map(Map, Arg, Ps).
ann_c_map_pair(Ann, Op, Key, Val) ->
cerl:ann_c_map_pair(Ann, Op, Key, Val).
-endif.