1008 lines
37 KiB
OCaml
1008 lines
37 KiB
OCaml
(**************************************************************************)
|
|
(* *)
|
|
(* Heptagon *)
|
|
(* *)
|
|
(* Author : Marc Pouzet *)
|
|
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
|
|
(* *)
|
|
(**************************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
open Format
|
|
open List
|
|
open Misc
|
|
open Names
|
|
open Ident
|
|
open Obc
|
|
open Modules
|
|
open Global
|
|
open C
|
|
open Location
|
|
open Printf
|
|
|
|
module Error =
|
|
struct
|
|
type error =
|
|
| Evar of string
|
|
| Enode of string
|
|
| Eno_unnamed_output
|
|
|
|
let message loc kind =
|
|
begin match kind with
|
|
| Evar name ->
|
|
eprintf "%aCode generation : The variable name '%s' is unbound.\n"
|
|
output_location loc
|
|
name
|
|
| Enode name ->
|
|
eprintf "%aCode generation : The node name '%s' is unbound.\n"
|
|
output_location loc
|
|
name
|
|
| Eno_unnamed_output ->
|
|
eprintf "%aCode generation : Unnamed outputs are not supported. \n"
|
|
output_location loc
|
|
end;
|
|
raise Misc.Error
|
|
end
|
|
|
|
let struct_name = function
|
|
| Heptagon.Tid n -> n
|
|
| _ -> assert false
|
|
|
|
let cname_of_name' name = match name with
|
|
| Name n -> Name (cname_of_name n)
|
|
| _ -> name
|
|
|
|
let rec print_list ff print sep l =
|
|
match l with
|
|
| [] -> ()
|
|
| [x] -> print ff x
|
|
| x :: l ->
|
|
print ff x;
|
|
fprintf ff "%s@ " sep;
|
|
print_list ff print sep l
|
|
|
|
(* Function to deal with opened modules set. *)
|
|
type world = { mutable opened_modules : S.t }
|
|
let world = { opened_modules = S.empty }
|
|
|
|
let add_opened_module (m:string) =
|
|
world.opened_modules <- S.add (String.uncapitalize (cname_of_name m)) world.opened_modules
|
|
let get_opened_modules () =
|
|
S.elements world.opened_modules
|
|
let remove_opened_module (m:string) =
|
|
world.opened_modules <- S.remove m world.opened_modules
|
|
let reset_opened_modules () =
|
|
world.opened_modules <- S.empty
|
|
|
|
let shortname = function
|
|
| Name(n) -> n
|
|
| Modname(q) ->
|
|
if q.qual <> "Pervasives" then
|
|
add_opened_module q.qual;
|
|
q.id
|
|
|
|
(** Returns the information concerning a node given by name. *)
|
|
let node_info classln =
|
|
match classln with
|
|
| Modname {qual = modname; id = modname_name } ->
|
|
begin try
|
|
modname, find_value (Modname({qual = modname;
|
|
id = modname_name }))
|
|
with Not_found ->
|
|
(* name might be of the form Module.name, remove the module name*)
|
|
let ind_name = (String.length modname) + 1 in
|
|
let name = String.sub modname_name ind_name
|
|
((String.length modname_name)-ind_name) in
|
|
begin try
|
|
modname, find_value (Modname({qual = modname;
|
|
id = name }))
|
|
with Not_found ->
|
|
Error.message no_location (Error.Enode name)
|
|
end
|
|
end
|
|
| Name n ->
|
|
Error.message no_location (Error.Enode n)
|
|
|
|
let output_names_list sig_info =
|
|
let remove_option ad = match ad.a_name with
|
|
| Some n -> n
|
|
| None -> Error.message no_location Error.Eno_unnamed_output (*TODO fresh*)
|
|
in
|
|
List.map remove_option sig_info.info.outputs
|
|
|
|
(******************************)
|
|
|
|
(** {2 Translation from Obc to C using our AST.} *)
|
|
|
|
(** [fold_stm_list] is an utility function that transforms a list of statements
|
|
into one statements using Cseq constructors. *)
|
|
|
|
(** [ctype_of_type mods oty] translates the Obc type [oty] to a C
|
|
type. We assume that identified types have already been defined
|
|
before use. [mods] is an accumulator for modules to be opened for
|
|
each function (i.e., not opened by an "open" declaration).
|
|
We have to make a difference between function args and local vars
|
|
because of arrays (when used as args, we use a pointer).
|
|
*)
|
|
let rec ctype_of_otype oty =
|
|
match oty with
|
|
| Tint -> Cty_int
|
|
| Tfloat -> Cty_float
|
|
| Tid id ->
|
|
begin match shortname id with
|
|
(* standard C practice: use int as boolean type. *)
|
|
| "bool" -> Cty_int
|
|
| "int" -> Cty_int
|
|
| "float" -> Cty_float
|
|
| id -> Cty_id id
|
|
end
|
|
| Tarray(ty, n) ->
|
|
Cty_arr(n, ctype_of_otype ty)
|
|
|
|
let ctype_of_heptty ty =
|
|
let ty = Merge.translate_btype ty in
|
|
let ty = Translate.translate_type NamesEnv.empty ty in
|
|
ctype_of_otype ty
|
|
|
|
let cvarlist_of_ovarlist vl =
|
|
let cvar_of_ovar vd =
|
|
let ty = ctype_of_otype vd.v_type in
|
|
let ty = if vd.v_pass_by_ref then pointer_to ty else ty in
|
|
name vd.v_name, ty
|
|
in
|
|
List.map cvar_of_ovar vl
|
|
|
|
let copname = function
|
|
| "=" -> "==" | "<>" -> "!=" | "&" -> "&&" | "or" -> "||" | "+" -> "+"
|
|
| "-" -> "-" | "*" -> "*" | "/" -> "/" | "*." -> "*" | "/." -> "/"
|
|
| "+." -> "+" | "-." -> "-" | "<" -> "<" | ">" -> ">" | "<=" -> "<="
|
|
| ">=" -> ">="
|
|
| "~-" -> "-" | "not" -> "!"
|
|
| op -> op
|
|
|
|
(** Translates an Obc var_dec to a tuple (name, cty). *)
|
|
let cvar_of_vd vd =
|
|
name vd.v_name, ctype_of_otype vd.v_type
|
|
|
|
(** If idx_list = [e1;..;ep], returns the lhs e[e1]...[ep] *)
|
|
let rec csubscript_of_e_list e idx_list =
|
|
match idx_list with
|
|
| [] -> e
|
|
| idx::idx_list ->
|
|
Carray (csubscript_of_e_list e idx_list, idx)
|
|
|
|
(** If idx_list = [i1;..;ip], returns the lhs e[i1]...[ip] *)
|
|
let csubscript_of_idx_list e idx_list =
|
|
csubscript_of_e_list e (List.map (fun i -> Cconst (Ccint i)) idx_list)
|
|
|
|
(** Creates the expression that checks that the indices
|
|
in idx_list are in the bounds. If idx_list=[e1;..;ep]
|
|
and bounds = [n1;..;np], it returns
|
|
e1 <= n1 && .. && ep <= np *)
|
|
let rec bound_check_expr idx_list bounds =
|
|
match idx_list, bounds with
|
|
| [idx], [n] ->
|
|
Cbop ("<", idx, Cconst (Ccint n))
|
|
| idx::idx_list, n::bounds ->
|
|
Cbop ("&", Cbop ("<", idx, Cconst (Ccint n)),
|
|
bound_check_expr idx_list bounds)
|
|
| _, _ -> assert false
|
|
|
|
(** Generate the expression to copy [src] into [dest], where bounds
|
|
represents the bounds of these two arrays. *)
|
|
let rec copy_array src dest bounds =
|
|
match bounds with
|
|
| [] -> [Caffect (dest, Clhs src)]
|
|
| n::bounds ->
|
|
let x = gen_symbol () in
|
|
[Cfor(x, 0, n,
|
|
copy_array (Carray (src, Clhs (Cvar x)))
|
|
(Carray (dest, Clhs (Cvar x))) bounds)]
|
|
|
|
(** Returns the type associated with the name [n]
|
|
in the environnement [var_env] (which is an association list
|
|
mapping strings to cty). *)
|
|
let rec assoc_type n var_env =
|
|
match var_env with
|
|
| [] -> Error.message no_location (Error.Evar n)
|
|
| (vn,ty)::var_env ->
|
|
if vn = n then
|
|
ty
|
|
else
|
|
assoc_type n var_env
|
|
|
|
(** Returns the type associated with the lhs [lhs]
|
|
in the environnement [var_env] (which is an association list
|
|
mapping strings to cty).*)
|
|
let rec assoc_type_lhs lhs var_env =
|
|
match lhs with
|
|
| Cvar x -> assoc_type x var_env
|
|
| Carray (lhs, idx) ->
|
|
let ty = assoc_type_lhs lhs var_env in
|
|
array_base_ctype ty [1]
|
|
| Cderef lhs -> assoc_type_lhs lhs var_env
|
|
| Cfield(Cderef (Cvar "self"), x) -> assoc_type x var_env
|
|
| Cfield(x, f) ->
|
|
let ty = assoc_type_lhs x var_env in
|
|
let { info = { arg = ty_arg; } } = find_field (longname f) in
|
|
let n = struct_name ty_arg in
|
|
let { info = { fields = fields } } = find_struct n in
|
|
ctype_of_heptty (List.assoc f fields)
|
|
| _ -> Cty_int (*TODO: add more cases*)
|
|
|
|
(** Creates the expression dest <- src (copying arrays if necessary). *)
|
|
let rec create_affect_stm dest src ty =
|
|
match ty with
|
|
| Cty_arr (n, bty) ->
|
|
let src = lhs_of_exp src in
|
|
let x = gen_symbol () in
|
|
[Cfor(x, 0, n,
|
|
create_affect_stm (Carray (dest, Clhs (Cvar x)))
|
|
(Clhs (Carray (src, Clhs (Cvar x)))) bty)]
|
|
| _ -> [Caffect (dest, src)]
|
|
|
|
(** Returns the expression to use e as an argument of
|
|
a function expecting a pointer as argument. *)
|
|
let address_of e =
|
|
try
|
|
let lhs = lhs_of_exp e in
|
|
match lhs with
|
|
| Carray _ -> Clhs lhs
|
|
| Cderef lhs -> Clhs lhs
|
|
| _ -> Caddrof lhs
|
|
with _ ->
|
|
e
|
|
|
|
(** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *)
|
|
let rec cexpr_of_exp var_env exp =
|
|
match exp with
|
|
(** Obj expressions that form valid C lhs are translated via clhs_of_exp. *)
|
|
| Lhs _ | Array_select _ ->
|
|
Clhs (clhs_of_exp var_env exp)
|
|
(** Constants, the easiest translation. *)
|
|
| Const lit ->
|
|
begin match lit with
|
|
| Cint i -> Cconst (Ccint i)
|
|
| Cfloat f -> Cconst (Ccfloat f)
|
|
| Cconstr c -> Cconst (Ctag (shortname c))
|
|
| Carray(n,c) ->
|
|
let cc = cexpr_of_exp var_env (Const c) in
|
|
Carraylit (repeat_list cc n)
|
|
end
|
|
(** Operators *)
|
|
| Op(op, exps) ->
|
|
cop_of_op var_env op exps
|
|
(** Structure literals. *)
|
|
| Struct (tyn, fl) ->
|
|
let cexps = List.map (fun (_,e) -> cexpr_of_exp var_env e) fl in
|
|
let ctyn = shortname tyn in
|
|
Cstructlit (ctyn, cexps)
|
|
| Array e_list ->
|
|
Carraylit (cexprs_of_exps var_env e_list)
|
|
|
|
and cexprs_of_exps var_env exps =
|
|
List.map (cexpr_of_exp var_env) exps
|
|
|
|
and cop_of_op_aux var_env op_name cexps =
|
|
match op_name with
|
|
| Modname { qual = "Pervasives"; id = op } ->
|
|
begin match op,cexps with
|
|
| "~-", [e] -> Cuop ("-", e)
|
|
| "not", [e] -> Cuop ("!", e)
|
|
| (
|
|
"=" | "<>"
|
|
| "&" | "or"
|
|
| "+" | "-" | "*" | "/"
|
|
| "*." | "/." | "+." | "-."
|
|
| "<" | ">" | "<=" | ">="), [el;er] ->
|
|
Cbop (copname op, el, er)
|
|
| _ -> Cfun_call(op, cexps)
|
|
end
|
|
| Modname {qual = m; id = op} ->
|
|
add_opened_module m;
|
|
Cfun_call(op,cexps)
|
|
| Name(op) ->
|
|
Cfun_call(op,cexps)
|
|
|
|
and cop_of_op var_env op_name exps =
|
|
let cexps = cexprs_of_exps var_env exps in
|
|
cop_of_op_aux var_env op_name cexps
|
|
|
|
and clhs_of_lhs var_env = function
|
|
(** Each Obc variable corresponds to a real local C variable. *)
|
|
| Var v ->
|
|
let n = name v in
|
|
let ty = assoc_type n var_env in
|
|
(match ty with
|
|
| Cty_ptr _ -> Cderef (Cvar n)
|
|
| _ -> Cvar n
|
|
)
|
|
(** Dereference our [self] struct holding the node's memory. *)
|
|
| Mem v -> Cfield (Cderef (Cvar "self"), name v)
|
|
(** Field access. /!\ Indexed Obj expression should be a valid lhs! *)
|
|
| Field (l, fn) -> Cfield(clhs_of_lhs var_env l, shortname fn)
|
|
| Array (l, idx) ->
|
|
Carray(clhs_of_lhs var_env e, cexpr_of_exp var_env idx)
|
|
|
|
and clhss_of_lhss var_env lhss =
|
|
List.map (clhs_of_lhs var_env) lhss
|
|
|
|
and clhs_of_exp var_env exp = match exp with
|
|
| Lhs l -> clhs_of_lhs var_env l
|
|
(** We were passed an expression that is not translatable to a valid C lhs?! *)
|
|
| _ -> invalid_arg "clhs_of_exp: argument not a Var, Mem or Field"
|
|
|
|
let rec assoc_obj instance obj_env =
|
|
match obj_env with
|
|
| [] -> raise Not_found
|
|
| od :: t ->
|
|
if od.obj = instance
|
|
then od
|
|
else assoc_obj instance t
|
|
|
|
let assoc_cn instance obj_env =
|
|
(assoc_obj instance obj_env).cls
|
|
|
|
let is_op = function
|
|
| Modname { qual = "Pervasives"; id = _ } -> true
|
|
| _ -> false
|
|
|
|
(** 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 sig_info args mem =
|
|
let rec add_targeting i l ads =
|
|
match l, ads with
|
|
| [] ,[] -> []
|
|
| e::l, ad::ads ->
|
|
let e =
|
|
if ad.a_pass_by_ref then
|
|
(*this arg is targeted, use a pointer*)
|
|
address_of e
|
|
else
|
|
e
|
|
in
|
|
e::(add_targeting (i+1) l ads)
|
|
| _ , _ -> assert false
|
|
in
|
|
(add_targeting 0 args sig_info.inputs)@[Caddrof mem]
|
|
|
|
(** 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 var_env obj_env outvl objn args mem =
|
|
(** Class name for the object to step. *)
|
|
let classln = assoc_cn objn obj_env in
|
|
let classn = shortname classln in
|
|
let mod_classn, sig_info = node_info classln in
|
|
|
|
let fun_call =
|
|
if is_op classln then
|
|
cop_of_op_aux var_env classln args
|
|
else
|
|
(** The step function takes scalar arguments and its own internal memory
|
|
holding structure. *)
|
|
let args = step_fun_call sig_info.info args mem in
|
|
(** Our C expression for the function call. *)
|
|
Cfun_call (classn ^ "_step", args)
|
|
in
|
|
|
|
(** Act according to the length of our list. Step functions with
|
|
multiple return values will return a structure, and we care of
|
|
assigning each field to the corresponding local variable. *)
|
|
match outvl with
|
|
| [] -> [Csexpr fun_call]
|
|
| [vr] when Heptagon.is_scalar_type (List.hd sig_info.info.outputs).a_type ->
|
|
[Caffect (vr, fun_call)]
|
|
| _ ->
|
|
(* Remove options *)
|
|
let out_sig = output_names_list sig_info in
|
|
let create_affect outv out_name =
|
|
let ty =
|
|
match outv with
|
|
| Cvar x -> assoc_type x var_env
|
|
| Carray(Cvar x, _) -> array_base_ctype (assoc_type x var_env) [1]
|
|
| Carray(Cfield(Cderef (Cvar "self"), x), _) ->
|
|
array_base_ctype (assoc_type x var_env) [1]
|
|
| _ -> Cty_void (*we don't care about the type*)
|
|
in
|
|
create_affect_stm outv
|
|
(Clhs (Cfield (mem,
|
|
mod_classn ^ "_" ^ out_name))) ty in
|
|
(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 c =
|
|
match c with
|
|
| Carray(n,c) ->
|
|
let x = gen_symbol () in
|
|
[ Cfor(x, 0, n,
|
|
create_affect_const var_env (Carray (dest, Clhs (Cvar x))) c) ]
|
|
| _ -> [Caffect (dest, cexpr_of_exp var_env (Const c))]
|
|
|
|
let create_field_update x r f v (n,ty) =
|
|
let ty = ctype_of_heptty ty in
|
|
if n = f then
|
|
create_affect_stm (Cfield(x,n)) v ty
|
|
else
|
|
create_affect_stm (Cfield(x, n)) (Clhs (Cfield(r,n))) ty
|
|
|
|
(** [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 var_env obj_env act =
|
|
match act with
|
|
(** Case on boolean values are converted to if instead of switch! *)
|
|
| Case (c, [(Name "true", te); (Name "false", fe)])
|
|
| Case (c, [(Name "false", fe); (Name "true", te)]) ->
|
|
let cc = cexpr_of_exp var_env c in
|
|
let cte = cstm_of_act var_env obj_env te in
|
|
let cfe = cstm_of_act var_env obj_env fe in
|
|
[Cif (cc, cte, cfe)]
|
|
(** Translation of case into a C switch statement is simple enough: we just
|
|
recursively translate obj expressions and statements to corresponding C
|
|
constructs, and cautiously "shortnamize" constructor names. *)
|
|
| Case (e, cl) ->
|
|
(** [ccl_of_obccl] translates an Obc clause to a C clause. *)
|
|
let ccl =
|
|
List.map (fun (c,act) -> shortname c, cstm_of_act var_env obj_env act) cl in
|
|
[Cswitch (cexpr_of_exp var_env e, ccl)]
|
|
(** For composition of statements, just recursively apply our translation
|
|
function on sub-statements. *)
|
|
| Comp (s1, s2) ->
|
|
let cstm1 = cstm_of_act var_env obj_env s1 in
|
|
let cstm2 = cstm_of_act var_env obj_env s2 in
|
|
cstm1@cstm2
|
|
(** Reinitialization of an object variable, extracting the reset function's
|
|
name from our environment [obj_env]. *)
|
|
| Reinit on ->
|
|
let obj = assoc_obj on obj_env in
|
|
let classn = shortname obj.cls in
|
|
if obj.n = 1 then
|
|
[Csexpr (Cfun_call (classn ^ "_reset",
|
|
[Caddrof (Cfield (Cderef (Cvar "self"), on))]))]
|
|
else
|
|
let x = gen_symbol () in
|
|
let field = Cfield (Cderef (Cvar "self"), on) in
|
|
let elt = [Caddrof( Carray(field, Clhs (Cvar x)) )] in
|
|
[Cfor(x, 0, obj.n,
|
|
[Csexpr (Cfun_call (classn ^ "_reset", elt ))] )]
|
|
(** Special case for x = 0^n^n...*)
|
|
| Assgn (vn, Const c) ->
|
|
let vn = clhs_of_lhs 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. *)
|
|
| Assgn (vn, e) ->
|
|
let vn = clhs_of_lhs var_env vn in
|
|
let ty = assoc_type_lhs vn var_env in
|
|
let ce = cexpr_of_exp var_env e in
|
|
create_affect_stm vn ce ty
|
|
(** Step functions applications can return multiple values, so we use a
|
|
local structure to hold the results, before allocating to our
|
|
variables. *)
|
|
| Step_ap (outvl, objn, el) ->
|
|
let args = cexprs_of_exps var_env el in
|
|
let outvl = clhss_of_lhss var_env outvl in
|
|
let mem = Cfield (Cderef (Cvar "self"), objn) in
|
|
generate_function_call var_env obj_env outvl objn args mem
|
|
|
|
| Array_select_dyn (x, e, idx_list, bounds, defv) ->
|
|
let x = clhs_of_lhs var_env x in
|
|
let ty = assoc_type_lhs x var_env in
|
|
let e = cexpr_of_exp var_env e in
|
|
let cexps = cexprs_of_exps var_env idx_list in
|
|
let defv = cexpr_of_exp var_env defv in
|
|
let c = bound_check_expr cexps bounds in
|
|
[Cif (c,
|
|
create_affect_stm x
|
|
(Clhs (csubscript_of_e_list (lhs_of_exp e) cexps)) ty,
|
|
create_affect_stm x defv ty)]
|
|
|
|
| Array_select_slice (x, e, idx1, idx2) ->
|
|
let x = clhs_of_lhs var_env x in
|
|
let ty = assoc_type_lhs x var_env in
|
|
let e = clhs_of_exp var_env e in
|
|
let y = gen_symbol () in
|
|
let index = Cbop ("+", Cconst (Ccint idx1), Clhs (Cvar y)) in
|
|
[Cfor(y, 0, idx2 - idx1 + 1,
|
|
create_affect_stm (Carray(x, index))
|
|
(Clhs (Carray(e, Clhs (Cvar y))))
|
|
(array_base_ctype ty [1]) )]
|
|
|
|
| Array_iterate (outvl, Imap, f, n, e_list) ->
|
|
let x = gen_symbol () in
|
|
let cexps = cexprs_of_exps var_env e_list in
|
|
let cexps = List.map (fun e -> Clhs (Carray(lhs_of_exp e, Clhs (Cvar x)))) cexps in
|
|
let outvl = clhss_of_lhss var_env outvl in
|
|
let outvl = List.map (fun n -> Carray(n, Clhs (Cvar x))) outvl in
|
|
let mem = Carray (Cfield (Cderef (Cvar "self"), f), Clhs (Cvar x)) in
|
|
let fcall = generate_function_call var_env obj_env outvl f cexps mem in
|
|
[ Cfor (x, 0, n, fcall) ]
|
|
|
|
| Array_iterate (outvl, Ifold, f, n, e_list) ->
|
|
let x = gen_symbol () in
|
|
let cexps = cexprs_of_exps var_env e_list in
|
|
(* Use the accumulator as the last arg *)
|
|
let cexps, acc_init = split_last cexps in
|
|
let cexps = List.map (fun e -> Clhs (Carray(lhs_of_exp e, Clhs (Cvar x)))) cexps in
|
|
let outvl = clhss_of_lhss var_env outvl in
|
|
let mem = Carray (Cfield (Cderef (Cvar "self"), f), Clhs (Cvar x)) in
|
|
(match outvl with
|
|
| [] ->
|
|
(* the accumulator is targeted, so it does not appear in the result. *)
|
|
let cexps = cexps@[acc_init] in
|
|
let fcall = generate_function_call var_env obj_env outvl f cexps mem in
|
|
[Cfor (x, 0, n, fcall) ]
|
|
| outvl ->
|
|
let cexps = cexps@[Clhs (List.hd outvl)] in
|
|
let fcall = generate_function_call var_env obj_env outvl f cexps mem in
|
|
let ty = assoc_type_lhs (List.hd outvl) var_env in
|
|
(create_affect_stm (List.hd outvl) acc_init ty) @ [Cfor (x, 0, n, fcall) ]
|
|
)
|
|
|
|
| Array_iterate (outvl, Imapfold, f, n, e_list) ->
|
|
let x = gen_symbol () in
|
|
let cexps = cexprs_of_exps var_env e_list in
|
|
(* Use the accumulator as the last arg *)
|
|
let cexps, acc_init = split_last cexps in
|
|
let cexps = List.map (fun e -> Clhs (Carray(lhs_of_exp e, Clhs (Cvar x)))) cexps in
|
|
let outvl = clhss_of_lhss var_env outvl in
|
|
let mem = Carray (Cfield (Cderef (Cvar "self"), f), Clhs (Cvar x)) in
|
|
|
|
(* Check if the accumulator is targeted and does not appear in the output. *)
|
|
let _, sig_info = node_info (assoc_cn f obj_env) in
|
|
let acc_is_targeted = (is_empty outvl)
|
|
or (last_element sig_info.info.inputs).a_pass_by_ref in
|
|
if acc_is_targeted then (
|
|
(* no accumulator in output *)
|
|
let outvl = List.map (fun e -> Carray(e, Clhs (Cvar x))) outvl in
|
|
let cexps = cexps@[acc_init] in
|
|
let fcall = generate_function_call var_env obj_env outvl f cexps mem in
|
|
[Cfor (x, 0, n, fcall) ]
|
|
) else (
|
|
(* use the last output as accumulator *)
|
|
let outvl = incomplete_map (fun e -> Carray(e, Clhs (Cvar x))) outvl in
|
|
let cexps = cexps@[(Clhs (last_element outvl))] in
|
|
let ty = assoc_type_lhs (last_element outvl) var_env in
|
|
let fcall = generate_function_call var_env obj_env outvl f cexps mem in
|
|
(create_affect_stm (last_element outvl) acc_init ty)@[Cfor (x, 0, n, fcall) ]
|
|
)
|
|
|
|
| Array_concat (x, e1, e2) ->
|
|
let x = clhs_of_lhs var_env x in
|
|
let e1 = clhs_of_exp var_env e1 in
|
|
let e2 = clhs_of_exp var_env e2 in
|
|
let ty1 = assoc_type_lhs e1 var_env in
|
|
let ty2 = assoc_type_lhs e2 var_env in
|
|
(match ty1, ty2 with
|
|
| Cty_arr(n1, t1), Cty_arr(n2, t2) ->
|
|
let y1 = gen_symbol () in
|
|
let y2 = gen_symbol () in
|
|
let index = Cbop ("+", Cconst (Ccint n1), Clhs (Cvar y2)) in
|
|
[Cfor(y1, 0, n1,
|
|
create_affect_stm (Carray(x, Clhs (Cvar y1)))
|
|
(Clhs (Carray(e1, Clhs (Cvar y1))))
|
|
t1 );
|
|
Cfor(y2, 0, n2,
|
|
create_affect_stm (Carray(x, index))
|
|
(Clhs (Carray(e2, Clhs (Cvar y2))))
|
|
t2 )]
|
|
| _, _ -> assert false
|
|
)
|
|
|
|
| Field_update(x, e1, f, e2) ->
|
|
(* Find the description of the struct type *)
|
|
let { info = { arg = ty_arg; res = ty_res } } = find_field f in
|
|
let n = struct_name ty_arg in
|
|
let { info = { fields = fields } } = find_struct n in
|
|
(* Translate exps *)
|
|
let f = shortname f in
|
|
let x = clhs_of_lhs var_env x in
|
|
let e1 = clhs_of_exp var_env e1 in
|
|
let e2 = cexpr_of_exp var_env e2 in
|
|
(* create the final exp*)
|
|
if x = e1 then ( (* only modify one field *)
|
|
let ty = ctype_of_heptty (List.assoc f fields) in
|
|
create_affect_stm (Cfield(x, f)) e2 ty
|
|
) else
|
|
List.flatten (List.map (create_field_update x e1 f e2) fields)
|
|
|
|
(** Well, Nothing translates to no instruction. *)
|
|
| Nothing -> []
|
|
|
|
(** [main_def_of_class_def cd] generated a main() function that repeatedly reads
|
|
data from standard input and then outputs result of [cd.step]. *)
|
|
(* TODO: refactor into something more readable. *)
|
|
let main_def_of_class_def cd =
|
|
(** Generates scanf statements, conversion to enums and declarations of
|
|
buffers needed for reading enum tags. *)
|
|
let scanf_and_vardecl_of_param vd =
|
|
let (formats, expr, need_buf) = match vd.v_type with
|
|
| Tint -> ("%d", Caddrof (Cvar (name vd.v_name)), None)
|
|
| Tid (Name "int"| Modname {qual="Pervasives";id="int"}) ->
|
|
("%d", Caddrof (Cvar (name vd.v_name)), None)
|
|
| Tid (Name "bool"| Modname {qual="Pervasives";id="bool"}) ->
|
|
("%d", Caddrof (Cvar (name vd.v_name)), None)
|
|
| Tfloat -> ("%f", Caddrof (Cvar (name vd.v_name)), None)
|
|
(* TODO: distinguish struct and enums AND switch to sscanf *)
|
|
| Tid ((Name sid) |
|
|
(Modname { id = sid })) -> ("%s",
|
|
Clhs (Cvar ((name vd.v_name) ^ "_buf")),
|
|
Some ((name vd.v_name) ^ "_buf", sid))
|
|
| Tarray(ty, n) -> assert false
|
|
in
|
|
let scane =
|
|
let puts_arg = Printf.sprintf "%s ? " (name vd.v_name) in
|
|
Csblock { var_decls = [];
|
|
block_body = [Csexpr (Cfun_call ("printf",
|
|
[Cconst (Cstrlit puts_arg)]));
|
|
Csexpr (Cfun_call ("scanf",
|
|
[Cconst (Cstrlit formats);
|
|
expr]));]; } in
|
|
match need_buf with
|
|
| None -> ([scane], [])
|
|
| Some (bufn, tyn) -> ([scane;
|
|
Csexpr (Cfun_call (tyn ^ "_of_string",
|
|
[Clhs (Cvar bufn)]))],
|
|
[(bufn, Cty_arr (20, Cty_char))]) in
|
|
let (scanf_calls, scanf_decls) =
|
|
split (map scanf_and_vardecl_of_param cd.step.inp) in
|
|
(** Generates printf statements and buffer declarations needed for printing
|
|
resulting values of enum types. *)
|
|
let printf_and_vardecl_of_result f vd =
|
|
let (formats, expr, need_buf) = match vd.v_type with
|
|
| Tint -> ("%d", f vd.v_name, None)
|
|
| Tfloat -> ("%f", f vd.v_name, None)
|
|
| Tid (Name "bool"| Modname {qual="Pervasives"; id="bool"}) ->
|
|
("%d", f vd.v_name, None)
|
|
| Tid (Name "int"| Modname {qual="Pervasives"; id="int"}) ->
|
|
("%d", f vd.v_name, None)
|
|
| Tid (Name sid | Modname {id = sid}) ->
|
|
("%s", Cfun_call ("string_of_" ^ sid,
|
|
[f vd.v_name;
|
|
Clhs (Cvar ((name vd.v_name) ^ "_buf"))]), Some (sid))
|
|
| Tarray (ty, n) -> assert false
|
|
in
|
|
(Csexpr (Cfun_call ("printf",
|
|
[Cconst (Cstrlit ("=> " ^ formats ^ "\\t")); expr])),
|
|
match need_buf with
|
|
| None -> []
|
|
| Some id -> [((name vd.v_name) ^ "_buf", Cty_arr (20, Cty_char))]) in
|
|
let (printf_calls, printf_decls) =
|
|
split (map (printf_and_vardecl_of_result
|
|
(fun n -> match cd.step.out with
|
|
| [vd] -> Clhs (Cvar "res")
|
|
| _ -> Clhs (Cfield (Cvar "res", name n)))) cd.step.out) in
|
|
let cinp = cvarlist_of_ovarlist cd.step.inp in
|
|
let cout =
|
|
begin match cd.step.out with
|
|
| [] -> []
|
|
| [vd] -> [("res", ctype_of_otype vd.v_type)]
|
|
| _ -> [("res", Cty_id (cd.cl_id ^ "_res"))]
|
|
end in
|
|
let varlist =
|
|
("mem", Cty_id (cd.cl_id ^ "_mem"))
|
|
:: cinp
|
|
@ cout
|
|
@ concat scanf_decls
|
|
@ concat printf_decls in
|
|
(** The main function loops (while (1) { ... }) reading arguments for our node
|
|
and prints the results. *)
|
|
let body =
|
|
let funcall =
|
|
let args =
|
|
map (fun vd -> Clhs (Cvar (name vd.v_name))) cd.step.inp
|
|
@ [Caddrof (Cvar ("mem"))] in
|
|
Cfun_call (cd.cl_id ^ "_step", args) in
|
|
concat scanf_calls
|
|
@ [Caffect (Cvar "res", funcall)]
|
|
@ printf_calls
|
|
@ [Csexpr (Cfun_call ("puts", [Cconst (Cstrlit "")]));
|
|
Csexpr (Cfun_call ("fflush", [Clhs (Cvar "stdout")]))] in
|
|
(** Do not forget to initialize memory via reset. *)
|
|
let init_mem =
|
|
Csexpr (Cfun_call (cd.cl_id ^ "_reset", [Caddrof (Cvar "mem")])) in
|
|
Cfundef {
|
|
f_name = "main";
|
|
f_retty = Cty_int;
|
|
f_args = [("argc", Cty_int); ("argv", Cty_ptr (Cty_ptr Cty_char))];
|
|
f_body = {
|
|
var_decls = varlist;
|
|
block_body = [init_mem;
|
|
Cwhile (Cconst (Ccint 1), body)];
|
|
}
|
|
}
|
|
|
|
(** Builds the argument list of step function*)
|
|
let step_fun_args n sf =
|
|
let args = cvarlist_of_ovarlist sf.inp in
|
|
args
|
|
@[("self", Cty_ptr (Cty_id (n ^ "_mem")))]
|
|
|
|
(** [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
|
|
reset calls. A step function can have multiple return values, whereas C does
|
|
not allow such functions. When it is the case, we declare a structure with a
|
|
field by return value. A scalar result is directly returned. *)
|
|
let fun_def_of_step_fun name obj_env mem sf =
|
|
let fun_name = name ^ "_step" in
|
|
(** Its arguments, translating Obc types to C types and adding our internal
|
|
memory structure. *)
|
|
let args = step_fun_args name sf in
|
|
(** Its normal local variables. *)
|
|
let local_vars = List.map cvar_of_vd sf.local in
|
|
(** Local variables containing return values. *)
|
|
let ret_vars =
|
|
if List.length sf.out = 1 && Obc.is_scalar_type (List.hd sf.out) then
|
|
List.map cvar_of_vd sf.out
|
|
else
|
|
[]
|
|
in
|
|
|
|
(** Return type, depending on the number of return values of our function. *)
|
|
let retty =
|
|
match sf.out with
|
|
| [] -> Cty_void
|
|
| [v] ->
|
|
if Obc.is_scalar_type v then
|
|
ctype_of_otype v.v_type
|
|
else
|
|
Cty_void
|
|
| _ -> Cty_void in
|
|
(** Controllable variables valuations *)
|
|
let use_ctrlr, ctrlr_calls =
|
|
match sf.controllables with
|
|
| [] -> false, []
|
|
| c_list ->
|
|
let args_inputs_state =
|
|
List.map (fun (arg_name,_) -> Clhs(Cvar(arg_name))) args in
|
|
let addr_controllables =
|
|
List.map (fun { v_name = c_name } -> Caddrof(Cvar(Ident.name c_name))) c_list in
|
|
let args_ctrlr =
|
|
args_inputs_state @ addr_controllables in
|
|
let funname = name ^ "_controller" in
|
|
let funcall = Cfun_call(funname,args_ctrlr) in
|
|
true,
|
|
[Csexpr(funcall)] in
|
|
(** The body *)
|
|
let mems = List.map cvar_of_vd (mem@sf.out) in
|
|
let var_env = args @ mems @ local_vars in
|
|
let body = cstm_of_act var_env obj_env sf.bd in
|
|
|
|
(** Our epilogue: affect each local variable holding a return value to
|
|
the correct structure field. *)
|
|
let epilogue = match sf.out with
|
|
| [] -> []
|
|
| [vd] when Obc.is_scalar_type (List.hd sf.out) ->
|
|
[Creturn (Clhs (Cvar (Ident.name vd.v_name)))]
|
|
| out -> [] in
|
|
|
|
(** Substitute the return value variables with the corresponding
|
|
context field*)
|
|
let map = Csubst.assoc_map_for_fun sf in
|
|
let body = List.map (Csubst.subst_stm map) (body@epilogue) in
|
|
|
|
use_ctrlr,
|
|
Cfundef {
|
|
f_name = fun_name;
|
|
f_retty = retty;
|
|
f_args = args;
|
|
f_body = {
|
|
var_decls = ret_vars @ local_vars;
|
|
block_body = ctrlr_calls @ body
|
|
}
|
|
}
|
|
|
|
(** [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 =
|
|
(** This one just translates the class name to a struct name following the
|
|
convention we described above. *)
|
|
let struct_field_of_obj_dec l od =
|
|
if is_op od.cls then
|
|
l
|
|
else
|
|
let clsname = shortname od.cls in
|
|
let ty = Cty_id ((cname_of_name clsname) ^ "_mem") in
|
|
let ty = if od.n <> 1 then Cty_arr (od.n, ty) else ty in
|
|
(od.obj, ty)::l
|
|
in
|
|
|
|
(** Fields corresponding to normal memory variables. *)
|
|
let mem_fields = List.map cvar_of_vd cd.mem in
|
|
(** Fields corresponding to object variables. *)
|
|
let obj_fields = List.fold_left struct_field_of_obj_dec [] cd.objs in
|
|
(** Fields corresponding to output variables. *)
|
|
let out_fields =
|
|
if (List.length cd.step.out) <> 1 or
|
|
not (Obc.is_scalar_type (List.hd cd.step.out)) then
|
|
List.map cvar_of_vd cd.step.out
|
|
else
|
|
[]
|
|
in
|
|
Cdecl_struct (cd.cl_id ^ "_mem", mem_fields @ obj_fields @ out_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 var_env = List.map cvar_of_vd cd.mem in
|
|
let body = cstm_of_act var_env cd.objs cd.reset in
|
|
Cfundef {
|
|
f_name = (cd.cl_id ^ "_reset");
|
|
f_retty = Cty_void;
|
|
f_args = [("self", Cty_ptr (Cty_id (cd.cl_id ^ "_mem")))];
|
|
f_body = {
|
|
var_decls = [];
|
|
block_body = body;
|
|
}
|
|
}
|
|
|
|
(** [cdecl_and_cfun_of_class_def cd] translates the class definition [cd] to
|
|
a C program. *)
|
|
let cdefs_and_cdecls_of_class_def cd =
|
|
(** We keep the state of our class in a structure, holding both internal
|
|
variables and the state of other nodes. For a class named ["cname"], the
|
|
structure will be called ["cname_mem"]. *)
|
|
let memory_struct_decl = mem_decl_of_class_def cd in
|
|
(** Our main() function will be generated only if the current class definition
|
|
corresponds to the simulation_node. *)
|
|
let main_def = match !simulation_node with
|
|
| Some nn when nn = cd.cl_id -> [main_def_of_class_def cd]
|
|
| _ -> [] in
|
|
let obj_env =
|
|
List.map (fun od -> { od with cls = cname_of_name' od.cls }) cd.objs in
|
|
let use_ctrlr,step_fun_def
|
|
= fun_def_of_step_fun cd.cl_id obj_env cd.mem cd.step 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
|
|
memory_struct_decl,
|
|
use_ctrlr,
|
|
([res_fun_decl;step_fun_decl],
|
|
reset_fun_def :: step_fun_def :: main_def)
|
|
|
|
let decls_of_type_decl otd =
|
|
let name = otd.t_name in
|
|
match otd.t_desc with
|
|
| Type_abs -> [] (*assert false*)
|
|
| Type_enum nl ->
|
|
[Cdecl_enum (otd.t_name, nl);
|
|
Cdecl_function (name ^ "_of_string",
|
|
Cty_id name,
|
|
[("s", Cty_ptr Cty_char)]);
|
|
Cdecl_function ("string_of_" ^ name,
|
|
Cty_ptr Cty_char,
|
|
[("x", Cty_id name); ("buf", Cty_ptr Cty_char)])]
|
|
| Type_struct fl ->
|
|
let decls = List.map (fun (n,ty) -> n, ctype_of_otype ty) fl in
|
|
[Cdecl_struct (otd.t_name, decls)];;
|
|
|
|
(** Translates an Obc type declaration to its C counterpart. *)
|
|
let cdefs_and_cdecls_of_type_decl otd =
|
|
let name = otd.t_name in
|
|
match otd.t_desc with
|
|
| Type_abs -> [], [] (*assert false*)
|
|
| Type_enum nl ->
|
|
let of_string_fun = Cfundef
|
|
{ f_name = name ^ "_of_string";
|
|
f_retty = Cty_id name;
|
|
f_args = [("s", Cty_ptr Cty_char)];
|
|
f_body =
|
|
{ var_decls = [];
|
|
block_body =
|
|
let gen_if t =
|
|
let funcall = Cfun_call ("strcmp", [Clhs (Cvar "s");
|
|
Cconst (Cstrlit t)]) in
|
|
let cond = Cbop ("==", funcall, Cconst (Ccint 0)) in
|
|
Cif (cond, [Creturn (Cconst (Ctag t))], []) in
|
|
map gen_if nl; }
|
|
}
|
|
and to_string_fun = Cfundef
|
|
{ f_name = "string_of_" ^ name;
|
|
f_retty = Cty_ptr Cty_char;
|
|
f_args = [("x", Cty_id name); ("buf", Cty_ptr Cty_char)];
|
|
f_body =
|
|
{ var_decls = [];
|
|
block_body =
|
|
let gen_clause t =
|
|
let fun_call =
|
|
Cfun_call ("strcpy", [Clhs (Cvar "buf");
|
|
Cconst (Cstrlit t)]) in
|
|
(t, [Csexpr fun_call]) in
|
|
[Cswitch (Clhs (Cvar "x"), map gen_clause nl);
|
|
Creturn (Clhs (Cvar "buf"))]; }
|
|
} in
|
|
([of_string_fun; to_string_fun],
|
|
[Cdecl_enum (otd.t_name, nl); cdecl_of_cfundef of_string_fun;
|
|
cdecl_of_cfundef to_string_fun])
|
|
| Type_struct fl ->
|
|
let decls = List.map (fun (n,ty) -> n, ctype_of_otype ty) fl in
|
|
let decl = Cdecl_struct (otd.t_name, decls) in
|
|
([], [decl])
|
|
|
|
(** [cfile_list_of_oprog oprog] translates the Obc program [oprog] to a list of
|
|
C source and header files. *)
|
|
let cfile_list_of_oprog name oprog =
|
|
let opened_modules = oprog.o_opened in
|
|
|
|
let header_and_source_of_class_def (deps,acc_cfiles) cd =
|
|
reset_opened_modules ();
|
|
List.iter add_opened_module opened_modules;
|
|
List.iter add_opened_module deps;
|
|
|
|
let cfile_name = String.uncapitalize cd.cl_id in
|
|
let mem_cdecl,use_ctrlr,(cdecls, cdefs) = cdefs_and_cdecls_of_class_def cd in
|
|
|
|
let cfile_mem = cfile_name ^ "_mem" in
|
|
add_opened_module cfile_mem;
|
|
if use_ctrlr then
|
|
add_opened_module (cfile_name ^ "_controller");
|
|
remove_opened_module name;
|
|
|
|
let acc_cfiles = acc_cfiles @
|
|
[ (cfile_mem ^ ".h", Cheader (get_opened_modules (),[mem_cdecl]));
|
|
(cfile_name ^ ".h", Cheader (get_opened_modules (), cdecls));
|
|
(cfile_name ^ ".c", Csource cdefs)] in
|
|
deps@[cfile_name],acc_cfiles in
|
|
|
|
reset_opened_modules ();
|
|
List.iter add_opened_module opened_modules;
|
|
let cdefs_and_cdecls = List.map cdefs_and_cdecls_of_type_decl oprog.o_types in
|
|
remove_opened_module name;
|
|
|
|
let (cty_defs, cty_decls) = List.split (List.rev cdefs_and_cdecls) in
|
|
let filename_types = name ^ "_types" in
|
|
let types_h = (filename_types ^ ".h",
|
|
Cheader (get_opened_modules (), concat cty_decls)) in
|
|
let types_c = (filename_types ^ ".c", Csource (concat cty_defs)) in
|
|
let _,cfiles =
|
|
List.fold_left
|
|
header_and_source_of_class_def
|
|
([filename_types],[types_h;types_c])
|
|
oprog.o_defs in
|
|
cfiles
|
|
|
|
let global_file_header name prog =
|
|
let step_fun_decl cd =
|
|
let _,s = fun_def_of_step_fun cd.cl_id cd.objs cd.mem cd.step in
|
|
cdecl_of_cfundef s
|
|
in
|
|
reset_opened_modules ();
|
|
List.iter add_opened_module prog.o_opened;
|
|
|
|
let ty_decls = List.map decls_of_type_decl prog.o_types in
|
|
let ty_decls = List.concat ty_decls in
|
|
let mem_step_fun_decls = List.map mem_decl_of_class_def prog.o_defs in
|
|
let reset_fun_decls =
|
|
List.map (fun cd -> cdecl_of_cfundef (reset_fun_def_of_class_def cd)) prog.o_defs in
|
|
let step_fun_decls = List.map step_fun_decl prog.o_defs in
|
|
|
|
(name ^ ".h", Cheader (get_opened_modules (),
|
|
ty_decls
|
|
@ mem_step_fun_decls
|
|
@ reset_fun_decls
|
|
@ step_fun_decls))
|
|
|
|
(******************************)
|
|
|
|
let sanitize_identifier modname id = match id with
|
|
| "bool" -> "bool" | "int" -> "int" | "float" -> "float"
|
|
| "true" -> "true" | "false" -> "false"
|
|
| op -> modname ^ "_" ^ cname_of_name op
|
|
|
|
let translate name prog =
|
|
let modname = (Filename.basename name) in
|
|
let prog =
|
|
Rename.rename_program (sanitize_identifier (String.capitalize modname)) prog in
|
|
begin match !simulation_node with
|
|
| None -> ()
|
|
| Some s -> simulation_node := Some (String.capitalize name ^ "_" ^ s)
|
|
end;
|
|
let res =
|
|
(global_file_header modname prog) :: (cfile_list_of_oprog modname prog) in
|
|
if !Misc.verbose then Printf.printf "Translation into C code done.\n";
|
|
res
|