jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

Add support for _local_in in cexprs

Browse source
This commit is contained in:
jeltz 2020-12-22 20:54:16 +01:00
parent f864d10095
commit f72a092af3
Signed by: jeltz
GPG key ID: 800882B66C0C3326
1 changed files with 82 additions and 58 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

140
compiler/obc/c/cgen.ml
View file

@ -77,6 +77,24 @@ struct
raise Errors.Error
end
(* This type describes how of step functions' bodies must access
* their inputs. *)
type step_input =
{ struct_expr : cexpr option;
inputs : var_dec list }
let cvar_step_input var si =
let is_input = List.mem var (List.map (fun v -> v.v_ident) si.inputs) in
match si.struct_expr with
| Some sexp when is_input -> Cfield (sexp, local_qn (name var))
| _ -> Cvar (name var)
let mk_step_input inputs =
{ struct_expr = None; inputs = inputs }
let mk_step_input_packed sexp inputs =
{ struct_expr = Some sexp; inputs = inputs }
let struct_name ty =
match ty with
| Cty_id n -> n
@ -303,18 +321,18 @@ let rec cexpr_of_static_exp se =
| Stuple _ -> Misc.internal_error "cgen: static tuple"
(** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *)
and cexpr_of_exp out out_env var_env exp =
and cexpr_of_exp si out out_env var_env exp =
match exp.e_desc with
| Eextvalue w -> cexpr_of_ext_value out out_env var_env w
| Eextvalue w -> cexpr_of_ext_value si out out_env var_env w
(* Operators *)
| Eop(op, exps) -> cop_of_op out out_env var_env op exps
| Eop(op, exps) -> cop_of_op si out out_env var_env op exps
(* Structure literals. *)
| Estruct (tyn, fl) ->
let cexpr = cexpr_of_exp out out_env var_env in
let cexpr = cexpr_of_exp si out out_env var_env in
let cexps_assoc = List.rev_map (fun (f, e) -> f, cexpr e) fl in
cexpr_of_struct tyn cexps_assoc
| Earray e_list ->
Carraylit (cexprs_of_exps out out_env var_env e_list)
Carraylit (cexprs_of_exps si out out_env var_env e_list)
and cexpr_of_struct tyn cexps_assoc =
let cexps = List.fold_left
@ -323,8 +341,8 @@ and cexpr_of_struct tyn cexps_assoc =
(* Reverse `cexps' here because of the previous use of `List.fold_left'. *)
Cstructlit (cname_of_qn tyn, List.rev cexps)
and cexprs_of_exps out out_env var_env exps =
List.map (cexpr_of_exp out out_env var_env) exps
and cexprs_of_exps si out out_env var_env exps =
List.map (cexpr_of_exp si out out_env var_env) exps
and cop_of_op_aux op_name cexps = match op_name with
| { qual = Pervasives; name = op } ->
@ -348,18 +366,20 @@ and cop_of_op_aux op_name cexps = match op_name with
Cfun_call("fprintf", file::s::args)
| { name = op } -> Cfun_call(op,cexps)
and cop_of_op out out_env var_env op_name exps =
let cexps = cexprs_of_exps out out_env var_env exps in
and cop_of_op si out out_env var_env op_name exps =
let cexps = cexprs_of_exps si out out_env var_env exps in
cop_of_op_aux op_name cexps
and clhs_of_pattern out out_env var_env l = match l.pat_desc with
and clhs_of_pattern si out out_env var_env l = match l.pat_desc with
(* Each Obc variable corresponds to a real local C variable. *)
| Lvar v ->
let n = name v in
let n_lhs =
if IdentSet.mem v out_env
then CLfield (clhs_of_cexpr out, local_qn n)
else CLvar n
(* FIXME(Arduino): This is almost certainly useless, as inputs can't
* be lhs. *)
else clhs_of_cexpr (cvar_step_input v si)
in
if List.mem_assoc n var_env then
@ -373,15 +393,15 @@ and clhs_of_pattern out out_env var_env l = match l.pat_desc with
(* Dereference our [self] struct holding the node's memory. *)
| Lmem v -> CLfield (CLderef (CLvar "self"), local_qn (name v))
(* Field access. /!\ Indexed Obj expression should be a valid lhs! *)
| Lfield (l, fn) -> CLfield(clhs_of_pattern out out_env var_env l, fn)
| Lfield (l, fn) -> CLfield(clhs_of_pattern si out out_env var_env l, fn)
| Larray (l, idx) ->
CLarray(clhs_of_pattern out out_env var_env l,
cexpr_of_exp out out_env var_env idx)
CLarray(clhs_of_pattern si out out_env var_env l,
cexpr_of_exp si out out_env var_env idx)
and clhs_list_of_pattern_list out out_env var_env lhss =
List.map (clhs_of_pattern out out_env var_env) lhss
and clhs_list_of_pattern_list si out out_env var_env lhss =
List.map (clhs_of_pattern si out out_env var_env) lhss
and cexpr_of_pattern out out_env var_env l = match l.pat_desc with
and cexpr_of_pattern si out out_env var_env l = match l.pat_desc with
(* Each Obc variable corresponds to a real local C variable. *)
| Lvar v ->
let n = name v in
@ -402,12 +422,12 @@ and cexpr_of_pattern out out_env var_env l = match l.pat_desc with
(* Dereference our [self] struct holding the node's memory. *)
| Lmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v))
(* Field access. /!\ Indexed Obj expression should be a valid lhs! *)
| Lfield (l, fn) -> Cfield(cexpr_of_pattern out out_env var_env l, fn)
| Lfield (l, fn) -> Cfield(cexpr_of_pattern si out out_env var_env l, fn)
| Larray (l, idx) ->
Carray(cexpr_of_pattern out out_env var_env l,
cexpr_of_exp out out_env var_env idx)
Carray(cexpr_of_pattern si out out_env var_env l,
cexpr_of_exp si out out_env var_env idx)
and cexpr_of_ext_value out out_env var_env w = match w.w_desc with
and cexpr_of_ext_value si out out_env var_env w = match w.w_desc with
| Wconst c -> cexpr_of_static_exp c
(* Each Obc variable corresponds to a plain local C variable. *)
| Wvar v ->
@ -415,7 +435,7 @@ and cexpr_of_ext_value out out_env var_env w = match w.w_desc with
let n_lhs =
if IdentSet.mem v out_env
then Cfield (out, local_qn n)
else Cvar n
else cvar_step_input v si
in
if List.mem_assoc n var_env then
@ -428,10 +448,10 @@ and cexpr_of_ext_value out out_env var_env w = match w.w_desc with
(* Dereference our [self] struct holding the node's memory. *)
| Wmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v))
(* Field access. /!\ Indexed Obj expression should be a valid lhs! *)
| Wfield (l, fn) -> Cfield(cexpr_of_ext_value out out_env var_env l, fn)
| Wfield (l, fn) -> Cfield(cexpr_of_ext_value si out out_env var_env l, fn)
| Warray (l, idx) ->
Carray(cexpr_of_ext_value out out_env var_env l,
cexpr_of_exp out out_env var_env idx)
Carray(cexpr_of_ext_value si out out_env var_env l,
cexpr_of_exp si out out_env var_env idx)
let rec assoc_obj instance obj_env =
match obj_env with
@ -454,7 +474,7 @@ let out_var_name_of_objn o =
(** Creates the list of arguments to call a node. [targeting] is the targeting
of the called node, [mem] represents the node context and [args] the
argument list.*)
let step_fun_call out_env var_env sig_info objn out args =
let step_fun_call si out_v out_env var_env sig_info objn out args =
let rec add_targeting l ads = match l, ads with
| [], [] -> []
| e::l, ad::ads ->
@ -473,8 +493,7 @@ let step_fun_call out_env var_env sig_info objn out args =
let rec mk_idx pl = match pl with
| [] -> f
| p::pl ->
Carray (mk_idx pl, cexpr_of_pattern (Cderef (Cvar "_out"))
out_env var_env p)
Carray (mk_idx pl, cexpr_of_pattern si out_v out_env var_env p)
in
mk_idx l
) in
@ -486,7 +505,7 @@ let step_fun_call out_env var_env sig_info objn out args =
[outvl] is a list of lhs where to put the results.
[args] is the list of expressions to use as arguments.
[mem] is the lhs where is stored the node's context.*)
let generate_function_call out_env var_env obj_env outvl objn args =
let generate_function_call si out_v out_env var_env obj_env outvl objn args =
(* Class name for the object to step. *)
let classln = assoc_cn objn obj_env in
let classn = cname_of_qn classln in
@ -499,7 +518,9 @@ let generate_function_call out_env var_env obj_env outvl objn args =
else
(* The step function takes scalar arguments and its own internal memory
holding structure. *)
let args = step_fun_call out_env var_env sig_info objn out args in
let args =
step_fun_call si out_v out_env var_env sig_info objn out args
in
(* Our C expression for the function call. *)
Cfun_call (classn ^ "_step", args)
in
@ -557,23 +578,23 @@ let rec create_affect_const var_env (dest : clhs) c =
(** [cstm_of_act obj_env mods act] translates the Obj action [act] to a list of
C statements, using the association list [obj_env] to map object names to
class names. *)
let rec cstm_of_act out out_env var_env obj_env act =
let rec cstm_of_act si out out_env var_env obj_env act =
match act with
(* Cosmetic : cases on boolean values are converted to if statements. *)
| Acase (c, [({name = "true"}, te); ({ name = "false" }, fe)])
| Acase (c, [({name = "false"}, fe); ({ name = "true"}, te)]) ->
let cc = cexpr_of_exp out out_env var_env c in
let cte = cstm_of_act_list out out_env var_env obj_env te in
let cfe = cstm_of_act_list out out_env var_env obj_env fe in
let cc = cexpr_of_exp si out out_env var_env c in
let cte = cstm_of_act_list si out out_env var_env obj_env te in
let cfe = cstm_of_act_list si out out_env var_env obj_env fe in
[Cif (cc, cte, cfe)]
| Acase (c, [({name = "true"}, te)]) ->
let cc = cexpr_of_exp out out_env var_env c in
let cte = cstm_of_act_list out out_env var_env obj_env te in
let cc = cexpr_of_exp si out out_env var_env c in
let cte = cstm_of_act_list si out out_env var_env obj_env te in
let cfe = [] in
[Cif (cc, cte, cfe)]
| Acase (c, [({name = "false"}, fe)]) ->
let cc = Cuop ("!", (cexpr_of_exp out out_env var_env c)) in
let cte = cstm_of_act_list out out_env var_env obj_env fe in
let cc = Cuop ("!", (cexpr_of_exp si out out_env var_env c)) in
let cte = cstm_of_act_list si out out_env var_env obj_env fe in
let cfe = [] in
[Cif (cc, cte, cfe)]
@ -587,36 +608,36 @@ let rec cstm_of_act out out_env var_env obj_env act =
let ccl =
List.map
(fun (c,act) -> cname_of_qn c,
cstm_of_act_list out out_env var_env obj_env act) cl in
[Cswitch (cexpr_of_exp out out_env var_env e, ccl)]
cstm_of_act_list si out out_env var_env obj_env act) cl in
[Cswitch (cexpr_of_exp si out out_env var_env e, ccl)]
| Ablock b ->
cstm_of_act_list out out_env var_env obj_env b
cstm_of_act_list si out out_env var_env obj_env b
(* For composition of statements, just recursively apply our
translation function on sub-statements. *)
| Afor ({ v_ident = x }, i1, i2, act) ->
[Cfor(name x, cexpr_of_exp out out_env var_env i1,
cexpr_of_exp out out_env var_env i2,
cstm_of_act_list out out_env var_env obj_env act)]
[Cfor(name x, cexpr_of_exp si out out_env var_env i1,
cexpr_of_exp si out out_env var_env i2,
cstm_of_act_list si out out_env var_env obj_env act)]
(* Translate constant assignment *)
| Aassgn (vn, { e_desc = Eextvalue { w_desc = Wconst c }; }) ->
let vn = clhs_of_pattern out out_env var_env vn in
let vn = clhs_of_pattern si out out_env var_env vn in
create_affect_const var_env vn c
(* Purely syntactic translation from an Obc local variable to a C
local one, with recursive translation of the rhs expression. *)
| Aassgn (vn, e) ->
let vn = clhs_of_pattern out out_env var_env vn in
let vn = clhs_of_pattern si out out_env var_env vn in
let ty = assoc_type_lhs vn var_env in
let ce = cexpr_of_exp out out_env var_env e in
let ce = cexpr_of_exp si out out_env var_env e in
create_affect_stm vn ce ty
(* Our Aop marks an operator invocation that will perform side effects. Just
translate to a simple C statement. *)
| Aop (op_name, args) ->
[Csexpr (cop_of_op out out_env var_env op_name args)]
[Csexpr (cop_of_op si out out_env var_env op_name args)]
(* Reinitialization of an object variable, extracting the reset
function's name from our environment [obj_env]. *)
@ -636,7 +657,7 @@ let rec cstm_of_act out out_env var_env obj_env act =
[Csexpr (Cfun_call (classn ^ "_reset", [Caddrof field]))]
| p::pl ->
mk_loop pl
(Carray (field, cexpr_of_pattern out out_env var_env p))
(Carray (field, cexpr_of_pattern si out out_env var_env p))
in
mk_loop pl field
)
@ -645,20 +666,20 @@ let rec cstm_of_act out out_env var_env obj_env act =
local structure to hold the results, before allocating to our
variables. *)
| Acall (outvl, objn, Mstep, el) ->
let args = cexprs_of_exps out out_env var_env el in
let outvl = clhs_list_of_pattern_list out out_env var_env outvl in
generate_function_call out_env var_env obj_env outvl objn args
let args = cexprs_of_exps si out out_env var_env el in
let outvl = clhs_list_of_pattern_list si out out_env var_env outvl in
generate_function_call si out out_env var_env obj_env outvl objn args
| Acall (outv1, objn, MstepAsync, e1) ->
(* 1. Atomic copy of the inputs *)
(* 2. Atomic copy of the outputs *)
assert false
and cstm_of_act_list out out_env var_env obj_env b =
and cstm_of_act_list si out out_env var_env obj_env b =
let l = List.map cvar_of_vd b.b_locals in
let var_env = l @ var_env in
let cstm = List.flatten
(List.map (cstm_of_act out out_env var_env obj_env) b.b_body)
(List.map (cstm_of_act si out out_env var_env obj_env) b.b_body)
in
match l with
| [] -> cstm
@ -722,8 +743,9 @@ let fun_def_of_step_fun n obj_env mem objs md =
IdentSet.empty
md.m_outputs
in
let si = mk_step_input md.m_inputs in
let body =
cstm_of_act_list (Cderef (Cvar "_out")) out_env var_env obj_env md.m_body
cstm_of_act_list si (Cderef (Cvar "_out")) out_env var_env obj_env md.m_body
in
Cfundef {
@ -771,11 +793,12 @@ let async_fun_def_of_step_fun n obj_env mem objs md copy_in_name
let local_in = Cvar "_local_in" in
let local_out = Cvar "_local_out" in
let si = mk_step_input_packed local_in md.m_inputs in
let copy_in = Cfun_call (copy_in_name, [Caddrof local_in; Cvar "_in"]) in
(* FIXME(Arduino): rename input & output variables *)
let body =
cstm_of_act_list local_out out_env var_env obj_env md.m_body
cstm_of_act_list si local_out out_env var_env obj_env md.m_body
in
let copy_out = Cfun_call (copy_out_name, [Cvar "_out"; Caddrof local_out]) in
@ -836,9 +859,10 @@ let reset_fun_def_of_class_def cd =
let body =
if cd.cd_stateful then
let var_env = List.map cvar_of_vd cd.cd_mems in
let si = mk_step_input [] in
let reset = find_reset_method cd in
cstm_of_act_list (Cderef (Cvar "_out")) IdentSet.empty var_env cd.cd_objs
reset.m_body
cstm_of_act_list si (Cderef (Cvar "_out")) IdentSet.empty var_env
cd.cd_objs reset.m_body
else
[]
in