|
|
|
|
@ -34,6 +34,8 @@ open Idents
|
|
|
|
|
open Obc
|
|
|
|
|
open Obc_utils
|
|
|
|
|
open Types
|
|
|
|
|
open Async
|
|
|
|
|
open Async_avr
|
|
|
|
|
|
|
|
|
|
open Modules
|
|
|
|
|
open Signature
|
|
|
|
|
@ -76,6 +78,40 @@ struct
|
|
|
|
|
raise Errors.Error
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
type vars_rewriter =
|
|
|
|
|
{ vr_vars : IdentSet.t;
|
|
|
|
|
vr_rewrite : ident -> cexpr }
|
|
|
|
|
|
|
|
|
|
let vr_match vr var = IdentSet.mem var vr.vr_vars
|
|
|
|
|
|
|
|
|
|
let vr_direct vars =
|
|
|
|
|
{ vr_vars = vars;
|
|
|
|
|
vr_rewrite = fun var -> Cvar (name var) }
|
|
|
|
|
|
|
|
|
|
let vr_field st_expr vars =
|
|
|
|
|
{ vr_vars = vars;
|
|
|
|
|
vr_rewrite = fun var -> Cfield (st_expr, local_qn (name var)) }
|
|
|
|
|
|
|
|
|
|
let vr_rewrite vr var =
|
|
|
|
|
if vr_match vr var then
|
|
|
|
|
vr.vr_rewrite var
|
|
|
|
|
else
|
|
|
|
|
Cvar (name var)
|
|
|
|
|
|
|
|
|
|
let vr_compose a b =
|
|
|
|
|
let rewrite var =
|
|
|
|
|
let vr = if vr_match a var then a else b in
|
|
|
|
|
vr_rewrite vr var
|
|
|
|
|
in
|
|
|
|
|
{ vr_rewrite = rewrite;
|
|
|
|
|
vr_vars = IdentSet.union a.vr_vars b.vr_vars }
|
|
|
|
|
|
|
|
|
|
let ident_set_of_var_decs vds =
|
|
|
|
|
List.fold_left
|
|
|
|
|
(fun set vd -> IdentSet.add vd.v_ident set)
|
|
|
|
|
IdentSet.empty
|
|
|
|
|
vds
|
|
|
|
|
|
|
|
|
|
let struct_name ty =
|
|
|
|
|
match ty with
|
|
|
|
|
| Cty_id n -> n
|
|
|
|
|
@ -222,7 +258,10 @@ let rec assoc_type_lhs lhs var_env = match lhs with
|
|
|
|
|
| Cty_ptr ty -> ty
|
|
|
|
|
| _ -> Error.message no_location Error.Ederef_not_pointer)
|
|
|
|
|
| CLfield(CLderef (CLvar "self"), { name = x }) -> assoc_type x var_env
|
|
|
|
|
(* TODO(Arduino): it's probably not necessary, but we could choose to
|
|
|
|
|
use assoc_type depending on the async state of the node *)
|
|
|
|
|
| CLfield(CLderef (CLvar "_out"), { name = x }) -> assoc_type x var_env
|
|
|
|
|
| CLfield(CLvar "_local_out", { name = x }) -> assoc_type x var_env
|
|
|
|
|
| CLfield(x, f) ->
|
|
|
|
|
let ty = assoc_type_lhs x var_env in
|
|
|
|
|
let n = struct_name ty in
|
|
|
|
|
@ -299,18 +338,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_env var_env exp =
|
|
|
|
|
and cexpr_of_exp vr var_env exp =
|
|
|
|
|
match exp.e_desc with
|
|
|
|
|
| Eextvalue w -> cexpr_of_ext_value out_env var_env w
|
|
|
|
|
| Eextvalue w -> cexpr_of_ext_value vr var_env w
|
|
|
|
|
(* Operators *)
|
|
|
|
|
| Eop(op, exps) -> cop_of_op out_env var_env op exps
|
|
|
|
|
| Eop(op, exps) -> cop_of_op vr var_env op exps
|
|
|
|
|
(* Structure literals. *)
|
|
|
|
|
| Estruct (tyn, fl) ->
|
|
|
|
|
let cexpr = cexpr_of_exp out_env var_env in
|
|
|
|
|
let cexpr = cexpr_of_exp vr 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_env var_env e_list)
|
|
|
|
|
Carraylit (cexprs_of_exps vr var_env e_list)
|
|
|
|
|
|
|
|
|
|
and cexpr_of_struct tyn cexps_assoc =
|
|
|
|
|
let cexps = List.fold_left
|
|
|
|
|
@ -319,8 +358,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_env var_env exps =
|
|
|
|
|
List.map (cexpr_of_exp out_env var_env) exps
|
|
|
|
|
and cexprs_of_exps vr var_env exps =
|
|
|
|
|
List.map (cexpr_of_exp vr var_env) exps
|
|
|
|
|
|
|
|
|
|
and cop_of_op_aux op_name cexps = match op_name with
|
|
|
|
|
| { qual = Pervasives; name = op } ->
|
|
|
|
|
@ -344,20 +383,15 @@ 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_env var_env op_name exps =
|
|
|
|
|
let cexps = cexprs_of_exps out_env var_env exps in
|
|
|
|
|
and cop_of_op vr var_env op_name exps =
|
|
|
|
|
let cexps = cexprs_of_exps vr var_env exps in
|
|
|
|
|
cop_of_op_aux op_name cexps
|
|
|
|
|
|
|
|
|
|
and clhs_of_pattern out_env var_env l = match l.pat_desc with
|
|
|
|
|
and clhs_of_pattern vr 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 (CLderef (CLvar "_out"), local_qn n)
|
|
|
|
|
else CLvar n
|
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
let n_lhs = clhs_of_cexpr (vr_rewrite vr v) in
|
|
|
|
|
if List.mem_assoc n var_env then
|
|
|
|
|
let ty = assoc_type n var_env in
|
|
|
|
|
(match ty with
|
|
|
|
|
@ -369,24 +403,19 @@ and clhs_of_pattern 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_env var_env l, fn)
|
|
|
|
|
| Lfield (l, fn) -> CLfield(clhs_of_pattern vr var_env l, fn)
|
|
|
|
|
| Larray (l, idx) ->
|
|
|
|
|
CLarray(clhs_of_pattern out_env var_env l,
|
|
|
|
|
cexpr_of_exp out_env var_env idx)
|
|
|
|
|
CLarray(clhs_of_pattern vr var_env l,
|
|
|
|
|
cexpr_of_exp vr var_env idx)
|
|
|
|
|
|
|
|
|
|
and clhs_list_of_pattern_list out_env var_env lhss =
|
|
|
|
|
List.map (clhs_of_pattern out_env var_env) lhss
|
|
|
|
|
and clhs_list_of_pattern_list vr var_env lhss =
|
|
|
|
|
List.map (clhs_of_pattern vr var_env) lhss
|
|
|
|
|
|
|
|
|
|
and cexpr_of_pattern out_env var_env l = match l.pat_desc with
|
|
|
|
|
and cexpr_of_pattern vr 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 Cfield (Cderef (Cvar "_out"), local_qn n)
|
|
|
|
|
else Cvar n
|
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
let n_lhs = vr_rewrite vr v in
|
|
|
|
|
if List.mem_assoc n var_env then
|
|
|
|
|
let ty = assoc_type n var_env in
|
|
|
|
|
(match ty with
|
|
|
|
|
@ -398,22 +427,17 @@ and cexpr_of_pattern 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_env var_env l, fn)
|
|
|
|
|
| Lfield (l, fn) -> Cfield(cexpr_of_pattern vr var_env l, fn)
|
|
|
|
|
| Larray (l, idx) ->
|
|
|
|
|
Carray(cexpr_of_pattern out_env var_env l,
|
|
|
|
|
cexpr_of_exp out_env var_env idx)
|
|
|
|
|
Carray(cexpr_of_pattern vr var_env l,
|
|
|
|
|
cexpr_of_exp vr var_env idx)
|
|
|
|
|
|
|
|
|
|
and cexpr_of_ext_value out_env var_env w = match w.w_desc with
|
|
|
|
|
and cexpr_of_ext_value vr 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 ->
|
|
|
|
|
let n = name v in
|
|
|
|
|
let n_lhs =
|
|
|
|
|
if IdentSet.mem v out_env
|
|
|
|
|
then Cfield (Cderef (Cvar "_out"), local_qn n)
|
|
|
|
|
else Cvar n
|
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
let n_lhs = vr_rewrite vr v in
|
|
|
|
|
if List.mem_assoc n var_env then
|
|
|
|
|
let ty = assoc_type n var_env in
|
|
|
|
|
(match ty with
|
|
|
|
|
@ -424,10 +448,10 @@ and cexpr_of_ext_value 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_env var_env l, fn)
|
|
|
|
|
| Wfield (l, fn) -> Cfield(cexpr_of_ext_value vr var_env l, fn)
|
|
|
|
|
| Warray (l, idx) ->
|
|
|
|
|
Carray(cexpr_of_ext_value out_env var_env l,
|
|
|
|
|
cexpr_of_exp out_env var_env idx)
|
|
|
|
|
Carray(cexpr_of_ext_value vr var_env l,
|
|
|
|
|
cexpr_of_exp vr var_env idx)
|
|
|
|
|
|
|
|
|
|
let rec assoc_obj instance obj_env =
|
|
|
|
|
match obj_env with
|
|
|
|
|
@ -450,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 vr var_env sig_info objn out args async =
|
|
|
|
|
let rec add_targeting l ads = match l, ads with
|
|
|
|
|
| [], [] -> []
|
|
|
|
|
| e::l, ad::ads ->
|
|
|
|
|
@ -468,34 +492,50 @@ let step_fun_call out_env var_env sig_info objn out args =
|
|
|
|
|
let f = Cfield (Cderef (Cvar "self"), local_qn (name o)) in
|
|
|
|
|
let rec mk_idx pl = match pl with
|
|
|
|
|
| [] -> f
|
|
|
|
|
| p::pl -> Carray (mk_idx pl, cexpr_of_pattern out_env var_env p)
|
|
|
|
|
| p::pl ->
|
|
|
|
|
Carray (mk_idx pl, cexpr_of_pattern vr var_env p)
|
|
|
|
|
in
|
|
|
|
|
mk_idx l
|
|
|
|
|
) in
|
|
|
|
|
args@[Caddrof out; Caddrof mem]
|
|
|
|
|
match async with
|
|
|
|
|
| Some async -> args @ [Caddrof out; Caddrof async]
|
|
|
|
|
| None -> args @ [Caddrof out; Caddrof mem]
|
|
|
|
|
) else
|
|
|
|
|
args@[Caddrof out]
|
|
|
|
|
match async with
|
|
|
|
|
| Some async -> args @ [Caddrof out; Caddrof async]
|
|
|
|
|
| None -> args @ [Caddrof out]
|
|
|
|
|
|
|
|
|
|
(** Generate the statement to call [objn].
|
|
|
|
|
[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 vr 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
|
|
|
|
|
let sig_info = find_value classln in
|
|
|
|
|
let out = Cvar (out_var_name_of_objn classn) in
|
|
|
|
|
let od = assoc_obj (obj_ref_name objn) obj_env in
|
|
|
|
|
|
|
|
|
|
let fun_call =
|
|
|
|
|
if is_op classln then
|
|
|
|
|
cop_of_op_aux classln 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 async = match od.o_ack with
|
|
|
|
|
| Some _ -> Some (Cvar (async_global_var_name od))
|
|
|
|
|
| None -> None
|
|
|
|
|
in
|
|
|
|
|
(* The step function takes scalar arguments and its own internal
|
|
|
|
|
memory holding structure. *)
|
|
|
|
|
let args =
|
|
|
|
|
step_fun_call vr var_env sig_info objn out args async
|
|
|
|
|
in
|
|
|
|
|
(* Our C expression for the function call. *)
|
|
|
|
|
Cfun_call (classn ^ "_step", args)
|
|
|
|
|
let suffix = match od.o_ack with
|
|
|
|
|
| Some _ -> "_step_async_stub"
|
|
|
|
|
| None -> "_step"
|
|
|
|
|
in
|
|
|
|
|
Cfun_call (classn ^ suffix, args)
|
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
(* Act according to the length of our list. Step functions with
|
|
|
|
|
@ -513,7 +553,7 @@ let generate_function_call out_env var_env obj_env outvl objn args =
|
|
|
|
|
let ty = assoc_type_lhs outv var_env in
|
|
|
|
|
create_affect_stm outv (Cfield (out, local_qn out_name)) ty
|
|
|
|
|
in
|
|
|
|
|
(Csexpr fun_call)::(List.flatten (map2 create_affect outvl out_sig))
|
|
|
|
|
(Csexpr fun_call) :: (List.flatten (map2 create_affect outvl out_sig))
|
|
|
|
|
|
|
|
|
|
(** Create the statement dest = c where c = v^n^m... *)
|
|
|
|
|
let rec create_affect_const var_env (dest : clhs) c =
|
|
|
|
|
@ -551,23 +591,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_env var_env obj_env act =
|
|
|
|
|
let rec cstm_of_act vr 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_env var_env c in
|
|
|
|
|
let cte = cstm_of_act_list out_env var_env obj_env te in
|
|
|
|
|
let cfe = cstm_of_act_list out_env var_env obj_env fe in
|
|
|
|
|
let cc = cexpr_of_exp vr var_env c in
|
|
|
|
|
let cte = cstm_of_act_list vr var_env obj_env te in
|
|
|
|
|
let cfe = cstm_of_act_list vr var_env obj_env fe in
|
|
|
|
|
[Cif (cc, cte, cfe)]
|
|
|
|
|
| Acase (c, [({name = "true"}, te)]) ->
|
|
|
|
|
let cc = cexpr_of_exp out_env var_env c in
|
|
|
|
|
let cte = cstm_of_act_list out_env var_env obj_env te in
|
|
|
|
|
let cc = cexpr_of_exp vr var_env c in
|
|
|
|
|
let cte = cstm_of_act_list vr 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_env var_env c)) in
|
|
|
|
|
let cte = cstm_of_act_list out_env var_env obj_env fe in
|
|
|
|
|
let cc = Cuop ("!", (cexpr_of_exp vr var_env c)) in
|
|
|
|
|
let cte = cstm_of_act_list vr var_env obj_env fe in
|
|
|
|
|
let cfe = [] in
|
|
|
|
|
[Cif (cc, cte, cfe)]
|
|
|
|
|
|
|
|
|
|
@ -581,36 +621,36 @@ let rec cstm_of_act out_env var_env obj_env act =
|
|
|
|
|
let ccl =
|
|
|
|
|
List.map
|
|
|
|
|
(fun (c,act) -> cname_of_qn c,
|
|
|
|
|
cstm_of_act_list out_env var_env obj_env act) cl in
|
|
|
|
|
[Cswitch (cexpr_of_exp out_env var_env e, ccl)]
|
|
|
|
|
cstm_of_act_list vr var_env obj_env act) cl in
|
|
|
|
|
[Cswitch (cexpr_of_exp vr var_env e, ccl)]
|
|
|
|
|
|
|
|
|
|
| Ablock b ->
|
|
|
|
|
cstm_of_act_list out_env var_env obj_env b
|
|
|
|
|
cstm_of_act_list vr 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_env var_env i1,
|
|
|
|
|
cexpr_of_exp out_env var_env i2,
|
|
|
|
|
cstm_of_act_list out_env var_env obj_env act)]
|
|
|
|
|
[Cfor(name x, cexpr_of_exp vr var_env i1,
|
|
|
|
|
cexpr_of_exp vr var_env i2,
|
|
|
|
|
cstm_of_act_list vr var_env obj_env act)]
|
|
|
|
|
|
|
|
|
|
(* Translate constant assignment *)
|
|
|
|
|
| Aassgn (vn, { e_desc = Eextvalue { w_desc = Wconst c }; }) ->
|
|
|
|
|
let vn = clhs_of_pattern out_env var_env vn in
|
|
|
|
|
let vn = clhs_of_pattern vr 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_env var_env vn in
|
|
|
|
|
let vn = clhs_of_pattern vr var_env vn in
|
|
|
|
|
let ty = assoc_type_lhs vn var_env in
|
|
|
|
|
let ce = cexpr_of_exp out_env var_env e in
|
|
|
|
|
let ce = cexpr_of_exp vr 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_env var_env op_name args)]
|
|
|
|
|
[Csexpr (cop_of_op vr var_env op_name args)]
|
|
|
|
|
|
|
|
|
|
(* Reinitialization of an object variable, extracting the reset
|
|
|
|
|
function's name from our environment [obj_env]. *)
|
|
|
|
|
@ -629,7 +669,8 @@ let rec cstm_of_act 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_env var_env p))
|
|
|
|
|
mk_loop pl
|
|
|
|
|
(Carray (field, cexpr_of_pattern vr var_env p))
|
|
|
|
|
in
|
|
|
|
|
mk_loop pl field
|
|
|
|
|
)
|
|
|
|
|
@ -638,19 +679,21 @@ let rec cstm_of_act 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_env var_env el in
|
|
|
|
|
let outvl = clhs_list_of_pattern_list out_env var_env outvl in
|
|
|
|
|
generate_function_call out_env var_env obj_env outvl objn args
|
|
|
|
|
let args = cexprs_of_exps vr var_env el in
|
|
|
|
|
let outvl = clhs_list_of_pattern_list vr var_env outvl in
|
|
|
|
|
generate_function_call vr var_env obj_env outvl objn args
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
and cstm_of_act_list out_env var_env obj_env b =
|
|
|
|
|
and cstm_of_act_list vr 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_env var_env obj_env) b.b_body) in
|
|
|
|
|
let cstm = List.flatten
|
|
|
|
|
(List.map (cstm_of_act vr var_env obj_env) b.b_body)
|
|
|
|
|
in
|
|
|
|
|
match l with
|
|
|
|
|
| [] -> cstm
|
|
|
|
|
| _ ->
|
|
|
|
|
[Csblock { var_decls = l; block_body = cstm }]
|
|
|
|
|
| _ -> [Csblock { var_decls = vardecl_of_cvars l;
|
|
|
|
|
block_body = cstm }]
|
|
|
|
|
|
|
|
|
|
(* TODO needed only because of renaming phase *)
|
|
|
|
|
let global_name = ref "";;
|
|
|
|
|
@ -659,22 +702,18 @@ let global_name = ref "";;
|
|
|
|
|
|
|
|
|
|
(** {2 step() and reset() functions generation} *)
|
|
|
|
|
|
|
|
|
|
let qn_append q suffix =
|
|
|
|
|
{ qual = q.qual; name = q.name ^ suffix }
|
|
|
|
|
|
|
|
|
|
(** Builds the argument list of step function*)
|
|
|
|
|
let step_fun_args n md =
|
|
|
|
|
let step_fun_args n md add_mem =
|
|
|
|
|
let args = inputlist_of_ovarlist md.m_inputs in
|
|
|
|
|
let out_arg = [("_out", Cty_ptr (Cty_id (qn_append n "_out")))] in
|
|
|
|
|
let context_arg =
|
|
|
|
|
if is_stateful n then
|
|
|
|
|
if is_stateful n && add_mem then
|
|
|
|
|
[("self", Cty_ptr (Cty_id (qn_append n "_mem")))]
|
|
|
|
|
else
|
|
|
|
|
[]
|
|
|
|
|
in
|
|
|
|
|
args @ out_arg @ context_arg
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** [fun_def_of_step_fun name obj_env mods sf] returns a C function definition
|
|
|
|
|
[name ^ "_out"] corresponding to the Obc step function [sf]. The object name
|
|
|
|
|
<-> class name mapping [obj_env] is needed to translate internal steps and
|
|
|
|
|
@ -685,7 +724,7 @@ let fun_def_of_step_fun n obj_env mem objs md =
|
|
|
|
|
let fun_name = (cname_of_qn n) ^ "_step" in
|
|
|
|
|
(* Its arguments, translating Obc types to C types and adding our internal
|
|
|
|
|
memory structure. *)
|
|
|
|
|
let args = step_fun_args n md in
|
|
|
|
|
let args = step_fun_args n md true in
|
|
|
|
|
|
|
|
|
|
(* Out vars for function calls *)
|
|
|
|
|
let out_vars =
|
|
|
|
|
@ -697,24 +736,125 @@ let fun_def_of_step_fun n obj_env mem objs md =
|
|
|
|
|
(* The body *)
|
|
|
|
|
let mems = List.map cvar_of_vd (mem@md.m_outputs) in
|
|
|
|
|
let var_env = args @ mems @ out_vars in
|
|
|
|
|
let out_env =
|
|
|
|
|
List.fold_left
|
|
|
|
|
(fun out_env vd -> IdentSet.add vd.v_ident out_env)
|
|
|
|
|
IdentSet.empty
|
|
|
|
|
md.m_outputs
|
|
|
|
|
let vr = vr_compose
|
|
|
|
|
(vr_field (Cderef (Cvar "_out")) (ident_set_of_var_decs md.m_outputs))
|
|
|
|
|
(vr_direct (ident_set_of_var_decs md.m_inputs))
|
|
|
|
|
in
|
|
|
|
|
let body =
|
|
|
|
|
cstm_of_act_list vr var_env obj_env md.m_body
|
|
|
|
|
in
|
|
|
|
|
let body = cstm_of_act_list out_env var_env obj_env md.m_body in
|
|
|
|
|
|
|
|
|
|
Cfundef {
|
|
|
|
|
C.f_name = fun_name;
|
|
|
|
|
f_retty = Cty_void;
|
|
|
|
|
f_args = args;
|
|
|
|
|
f_body = {
|
|
|
|
|
var_decls = out_vars;
|
|
|
|
|
var_decls = vardecl_of_cvars out_vars;
|
|
|
|
|
block_body = body
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
let async_ty n =
|
|
|
|
|
Cty_ptr (Cty_id (qn_append n "_async"))
|
|
|
|
|
|
|
|
|
|
let async_field_ptr name =
|
|
|
|
|
Caddrof (Cfield (Cderef (Cvar "_async"), local_qn name))
|
|
|
|
|
|
|
|
|
|
let fun_stub_def_of_step_fun n md copy_in copy_out =
|
|
|
|
|
let fun_name = (cname_of_qn n) ^ "_step_async_stub" in
|
|
|
|
|
let args = (step_fun_args n md false) @ [("_async", async_ty n)] in
|
|
|
|
|
let out_vars = [("_in", Cty_id (qn_append n "_in"))] in
|
|
|
|
|
|
|
|
|
|
let prologue = List.flatten (List.map
|
|
|
|
|
(fun (src_name, ty) ->
|
|
|
|
|
let src = Cvar src_name in
|
|
|
|
|
let dest = CLfield (CLvar "_in", local_qn src_name) in
|
|
|
|
|
create_affect_stm dest src ty)
|
|
|
|
|
(inputlist_of_ovarlist md.m_inputs))
|
|
|
|
|
in
|
|
|
|
|
let body = [
|
|
|
|
|
Csexpr (Cfun_call (copy_in, [async_field_ptr "in"; Caddrof (Cvar "_in")]));
|
|
|
|
|
Csexpr (Cfun_call (copy_out, [Cvar "_out"; async_field_ptr "out"]))
|
|
|
|
|
] in
|
|
|
|
|
|
|
|
|
|
Cfundef {
|
|
|
|
|
C.f_name = fun_name;
|
|
|
|
|
f_retty = Cty_void;
|
|
|
|
|
f_args = args;
|
|
|
|
|
f_body = {
|
|
|
|
|
var_decls = vardecl_of_cvars out_vars;
|
|
|
|
|
block_body = prologue @ body
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
let async_fun_def_of_step_fun n obj_env mem objs md copy_in copy_out =
|
|
|
|
|
let fun_name = (cname_of_qn n) ^ "_async_step" in
|
|
|
|
|
let args = [("_async", async_ty n)] in
|
|
|
|
|
|
|
|
|
|
(* Out vars for function calls *)
|
|
|
|
|
let out_vars =
|
|
|
|
|
unique
|
|
|
|
|
(List.map (fun obj -> out_var_name_of_objn (cname_of_qn obj.o_class),
|
|
|
|
|
Cty_id (qn_append obj.o_class "_out"))
|
|
|
|
|
(List.filter (fun obj -> not (is_op obj.o_class)) objs)) in
|
|
|
|
|
|
|
|
|
|
let out_vars =
|
|
|
|
|
List.fold_left
|
|
|
|
|
(fun out_vars s -> ("_local" ^ s, Cty_id (qn_append n s)) :: out_vars)
|
|
|
|
|
out_vars
|
|
|
|
|
["_in"; "_out"]
|
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
(* FIXME(Arduino): it is probably easier to access to self directly from
|
|
|
|
|
_async struct pointer, but the string "self" is hardcoded in a large
|
|
|
|
|
number of places… *)
|
|
|
|
|
let out_vars =
|
|
|
|
|
if is_stateful n then
|
|
|
|
|
("self", Cty_ptr (Cty_id (qn_append n "_mem"))) :: out_vars
|
|
|
|
|
else
|
|
|
|
|
out_vars
|
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
(* The body *)
|
|
|
|
|
let mems = List.map cvar_of_vd (mem@md.m_outputs) in
|
|
|
|
|
let var_env = args @ mems @ out_vars in
|
|
|
|
|
|
|
|
|
|
let async_field_ptr name =
|
|
|
|
|
Caddrof (Cfield (Cderef (Cvar "_async"), local_qn name))
|
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
let l_in = Cvar "_local_in" in
|
|
|
|
|
let l_out = Cvar "_local_out" in
|
|
|
|
|
|
|
|
|
|
let vr = vr_compose
|
|
|
|
|
(vr_field l_out (ident_set_of_var_decs md.m_outputs))
|
|
|
|
|
(vr_field l_in (ident_set_of_var_decs md.m_inputs))
|
|
|
|
|
in
|
|
|
|
|
|
|
|
|
|
let prologue = [
|
|
|
|
|
Csexpr (Cfun_call (copy_in, [Caddrof l_in; async_field_ptr "in"]))
|
|
|
|
|
] in
|
|
|
|
|
let prologue =
|
|
|
|
|
if is_stateful n then
|
|
|
|
|
(Caffect (CLvar "self", async_field_ptr "self")) :: prologue
|
|
|
|
|
else
|
|
|
|
|
prologue
|
|
|
|
|
in
|
|
|
|
|
let body = cstm_of_act_list vr var_env obj_env md.m_body in
|
|
|
|
|
let epilogue = [
|
|
|
|
|
Csexpr (Cfun_call (copy_out, [async_field_ptr "out"; Caddrof l_out]))
|
|
|
|
|
] in
|
|
|
|
|
|
|
|
|
|
Cfundef {
|
|
|
|
|
C.f_name = fun_name;
|
|
|
|
|
f_retty = Cty_void;
|
|
|
|
|
f_args = args;
|
|
|
|
|
f_body = {
|
|
|
|
|
var_decls = vardecl_of_cvars out_vars;
|
|
|
|
|
block_body = prologue @ body @ epilogue
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
(** [mem_decl_of_class_def cd] returns a declaration for a C structure holding
|
|
|
|
|
internal variables and objects of the Obc class definition [cd]. *)
|
|
|
|
|
let mem_decl_of_class_def cd =
|
|
|
|
|
@ -745,20 +885,42 @@ let mem_decl_of_class_def cd =
|
|
|
|
|
) else
|
|
|
|
|
[]
|
|
|
|
|
|
|
|
|
|
let in_decl_of_class_def cd =
|
|
|
|
|
let step_m = find_step_method cd in
|
|
|
|
|
let in_fields = List.map cvar_of_vd step_m.m_inputs in
|
|
|
|
|
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_in", in_fields)]
|
|
|
|
|
|
|
|
|
|
let out_decl_of_class_def cd =
|
|
|
|
|
(* Fields corresponding to output variables. *)
|
|
|
|
|
let step_m = find_step_method cd in
|
|
|
|
|
let out_fields = List.map cvar_of_vd step_m.m_outputs in
|
|
|
|
|
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_out", out_fields)]
|
|
|
|
|
|
|
|
|
|
let async_decl_of_class_def cd =
|
|
|
|
|
let struct_field suffix name =
|
|
|
|
|
let qn = qn_append cd.cd_name suffix in
|
|
|
|
|
(name, Cty_id qn)
|
|
|
|
|
in
|
|
|
|
|
let fields = [
|
|
|
|
|
struct_field "_in" "in";
|
|
|
|
|
struct_field "_out" "out"
|
|
|
|
|
] in
|
|
|
|
|
let fields = if is_stateful cd.cd_name then
|
|
|
|
|
(struct_field "_mem" "self") :: fields
|
|
|
|
|
else
|
|
|
|
|
fields
|
|
|
|
|
in
|
|
|
|
|
[Cdecl_struct ((cname_of_qn cd.cd_name) ^ "_async", fields)]
|
|
|
|
|
|
|
|
|
|
(** [reset_fun_def_of_class_def cd] returns the defintion of the C function
|
|
|
|
|
tasked to reset the class [cd]. *)
|
|
|
|
|
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 vr = vr_direct IdentSet.empty in
|
|
|
|
|
let reset = find_reset_method cd in
|
|
|
|
|
cstm_of_act_list IdentSet.empty var_env cd.cd_objs reset.m_body
|
|
|
|
|
cstm_of_act_list vr var_env cd.cd_objs reset.m_body
|
|
|
|
|
else
|
|
|
|
|
[]
|
|
|
|
|
in
|
|
|
|
|
@ -772,7 +934,6 @@ let reset_fun_def_of_class_def cd =
|
|
|
|
|
}
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** [cdecl_and_cfun_of_class_def cd] translates the class definition [cd] to
|
|
|
|
|
a C program. *)
|
|
|
|
|
let cdefs_and_cdecls_of_class_def cd =
|
|
|
|
|
@ -782,21 +943,38 @@ let cdefs_and_cdecls_of_class_def cd =
|
|
|
|
|
Idents.enter_node cd.cd_name;
|
|
|
|
|
let step_m = find_step_method cd in
|
|
|
|
|
let memory_struct_decl = mem_decl_of_class_def cd in
|
|
|
|
|
let in_struct_decl = in_decl_of_class_def cd in
|
|
|
|
|
let out_struct_decl = out_decl_of_class_def cd in
|
|
|
|
|
let step_fun_def = fun_def_of_step_fun cd.cd_name
|
|
|
|
|
cd.cd_objs cd.cd_mems cd.cd_objs step_m in
|
|
|
|
|
let async_struct_decl = async_decl_of_class_def cd in
|
|
|
|
|
let objs = async_global_objs_defs cd in
|
|
|
|
|
let objs_decls = async_global_objs_decls cd in
|
|
|
|
|
let step = fun_def_of_step_fun cd.cd_name cd.cd_objs cd.cd_mems
|
|
|
|
|
cd.cd_objs step_m in
|
|
|
|
|
(* TODO(Arduino): let the user choose the backend they want *)
|
|
|
|
|
let copy_in = AvrBackend.gen_copy_func_in cd in
|
|
|
|
|
let copy_out = AvrBackend.gen_copy_func_out cd in
|
|
|
|
|
let async_stub =
|
|
|
|
|
fun_stub_def_of_step_fun cd.cd_name step_m
|
|
|
|
|
(cdef_name copy_in) (cdef_name copy_out)
|
|
|
|
|
in
|
|
|
|
|
let async_step =
|
|
|
|
|
async_fun_def_of_step_fun cd.cd_name cd.cd_objs cd.cd_mems
|
|
|
|
|
cd.cd_objs step_m (cdef_name copy_in) (cdef_name copy_out)
|
|
|
|
|
in
|
|
|
|
|
(* C function for resetting our memory structure. *)
|
|
|
|
|
let reset_fun_def = reset_fun_def_of_class_def cd in
|
|
|
|
|
let res_fun_decl = cdecl_of_cfundef reset_fun_def in
|
|
|
|
|
let step_fun_decl = cdecl_of_cfundef step_fun_def in
|
|
|
|
|
let (decls, defs) =
|
|
|
|
|
let reset = reset_fun_def_of_class_def cd in
|
|
|
|
|
|
|
|
|
|
let defs = [step; copy_in; copy_out; async_stub; async_step] in
|
|
|
|
|
let defs =
|
|
|
|
|
if is_stateful cd.cd_name then
|
|
|
|
|
([res_fun_decl; step_fun_decl], [reset_fun_def; step_fun_def])
|
|
|
|
|
reset :: defs
|
|
|
|
|
else
|
|
|
|
|
([step_fun_decl], [step_fun_def]) in
|
|
|
|
|
defs
|
|
|
|
|
in
|
|
|
|
|
let decls = List.map cdecl_of_cfundef defs in
|
|
|
|
|
|
|
|
|
|
memory_struct_decl @ out_struct_decl @ decls,
|
|
|
|
|
defs
|
|
|
|
|
memory_struct_decl @ in_struct_decl @ out_struct_decl @ async_struct_decl
|
|
|
|
|
@ objs_decls @ decls, objs @ defs
|
|
|
|
|
|
|
|
|
|
(** {2 Type translation} *)
|
|
|
|
|
|
|
|
|
|
@ -883,9 +1061,17 @@ let global_file_header name prog =
|
|
|
|
|
| s -> s ^ "_types")
|
|
|
|
|
dependencies in
|
|
|
|
|
|
|
|
|
|
let dependencies_types = AvrBackend.includes @ dependencies_types in
|
|
|
|
|
|
|
|
|
|
let classes = program_classes prog in
|
|
|
|
|
let (decls, defs) =
|
|
|
|
|
List.split (List.map cdefs_and_cdecls_of_class_def classes) in
|
|
|
|
|
let async_objs = List.flatten
|
|
|
|
|
(List.map filter_async_objs classes)
|
|
|
|
|
in
|
|
|
|
|
let decls_and_defs = List.map cdefs_and_cdecls_of_class_def classes in
|
|
|
|
|
let decls_and_defs =
|
|
|
|
|
(AvrBackend.decls_and_defs async_objs) :: decls_and_defs
|
|
|
|
|
in
|
|
|
|
|
let (decls, defs) = List.split decls_and_defs in
|
|
|
|
|
let decls = List.concat decls
|
|
|
|
|
and defs = List.concat defs in
|
|
|
|
|
|
|
|
|
|
|
