918 lines
33 KiB
OCaml
918 lines
33 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 Signature
|
|
open C
|
|
open Location
|
|
open Printf
|
|
|
|
module Error =
|
|
struct
|
|
type error =
|
|
| Evar of string
|
|
| Enode of string
|
|
| Eno_unnamed_output
|
|
| Ederef_not_pointer
|
|
|
|
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
|
|
| Ederef_not_pointer ->
|
|
eprintf "%aCode generation : Trying to deference a non pointer type. \n"
|
|
output_location loc
|
|
end;
|
|
raise Misc.Error
|
|
end
|
|
|
|
let rec struct_name ty =
|
|
match ty with
|
|
| Cty_id n -> n
|
|
| _ -> assert false
|
|
|
|
let cname_of_name' name = match name with
|
|
| Name n -> Name (cname_of_name n)
|
|
| _ -> name
|
|
|
|
(* Functions 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
|
|
in
|
|
List.map remove_option sig_info.info.node_outputs
|
|
|
|
let is_scalar_type ty =
|
|
match ty with
|
|
| Types.Tid name_int when name_int = Initial.pint -> true
|
|
| Types.Tid name_float when name_float = Initial.pfloat -> true
|
|
| Types.Tid name_bool when name_bool = Initial.pbool -> true
|
|
| _ -> false
|
|
|
|
(******************************)
|
|
|
|
(** {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
|
|
| Tbool -> Cty_int
|
|
| 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 = Mls2obc.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
|
|
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)
|
|
|
|
(** 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)*)assert false
|
|
| (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, _) ->
|
|
let ty = assoc_type_lhs lhs var_env in
|
|
array_base_ctype ty [1]
|
|
| Cderef lhs ->
|
|
(match assoc_type_lhs lhs var_env with
|
|
| Cty_ptr ty -> ty
|
|
| _ -> Error.message no_location Error.Ederef_not_pointer
|
|
)
|
|
| Cfield(Cderef (Cvar "self"), x) -> assoc_type x var_env
|
|
| Cfield(x, f) ->
|
|
let ty = assoc_type_lhs x var_env in
|
|
let n = struct_name ty in
|
|
let { info = fields } = find_struct (longname n) in
|
|
ctype_of_heptty (field_assoc (Name f) fields)
|
|
|
|
(** Creates the statement a = [e_1, e_2, ..], which gives a list
|
|
a[i] = e_i.*)
|
|
let rec create_affect_lit dest l ty =
|
|
let rec _create_affect_lit dest i = function
|
|
| [] -> []
|
|
| v::l ->
|
|
let stm = create_affect_stm (Carray (dest, Cconst (Ccint i))) v ty in
|
|
stm@(_create_affect_lit dest (i+1) l)
|
|
in
|
|
_create_affect_lit dest 0 l
|
|
|
|
(** Creates the expression dest <- src (copying arrays if necessary). *)
|
|
and create_affect_stm dest src ty =
|
|
match ty with
|
|
| Cty_arr (n, bty) ->
|
|
(match src with
|
|
| Carraylit l -> create_affect_lit dest l bty
|
|
| Clhs src ->
|
|
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 _ ->
|
|
Clhs (clhs_of_exp var_env exp)
|
|
(** Constants, the easiest translation. *)
|
|
| Const lit ->
|
|
(match lit with
|
|
| Cint i -> Cconst (Ccint i)
|
|
| Cfloat f -> Cconst (Ccfloat f)
|
|
| Cconstr c -> Cconst (Ctag (shortname c))
|
|
| Obc.Carray(n,c) ->
|
|
let cc = cexpr_of_exp var_env (Const c) in
|
|
Carraylit (repeat_list cc n)
|
|
)
|
|
(** Operators *)
|
|
| Op(op, exps) ->
|
|
cop_of_op var_env op exps
|
|
(** Structure literals. *)
|
|
| Struct_lit (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_lit 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
|
|
if List.mem_assoc n var_env then
|
|
let ty = assoc_type n var_env in
|
|
(match ty with
|
|
| Cty_ptr _ -> Cderef (Cvar n)
|
|
| _ -> Cvar n
|
|
)
|
|
else
|
|
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 l, 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 =
|
|
match instance with
|
|
| Context obj
|
|
| Array_context (obj, _) -> (assoc_obj obj 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 =
|
|
args@[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 =
|
|
let mem =
|
|
(match objn with
|
|
| Context o -> Cfield (Cderef (Cvar "self"), o)
|
|
| Array_context (o, l) ->
|
|
let l = clhs_of_lhs var_env l in
|
|
Carray (Cfield (Cderef (Cvar "self"), o), Clhs l)
|
|
) in
|
|
(** 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 is_scalar_type (List.hd sig_info.info.node_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,
|
|
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
|
|
| Obc.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))]
|
|
|
|
(** [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. *)
|
|
| For (x, i1, i2, act) ->
|
|
[Cfor(name x, i1, i2, cstm_of_act var_env obj_env act)]
|
|
|
|
| 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.size = 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.size,
|
|
[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
|
|
generate_function_call var_env obj_env outvl objn args
|
|
|
|
(** Well, Nothing translates to no instruction. *)
|
|
| Nothing -> []
|
|
|
|
(* TODO needed only because of renaming phase *)
|
|
let global_name = ref "";;
|
|
|
|
(** [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 =
|
|
let format_for_type ty = match ty with
|
|
| Tarray _ -> assert false
|
|
| Tint | Tbool -> "%d"
|
|
| Tfloat -> "%f"
|
|
| Tid ((Name sid) | Modname { id = sid }) -> "%s" in
|
|
|
|
(** Does reading type [ty] need a buffer? When it is the case,
|
|
[need_buf_for_ty] also returns the type's name. *)
|
|
let need_buf_for_ty ty = match ty with
|
|
| Tarray _ -> assert false
|
|
| Tint | Tfloat | Tbool -> None
|
|
| Tid (Name sid | Modname { id = sid; }) -> Some sid in
|
|
|
|
let rec read_lhs_of_ty lhs ty = match ty with
|
|
| Tarray (ty, n) ->
|
|
let iter_var = Ident.name (Ident.fresh "i") in
|
|
let lhs = Carray (lhs, Clhs (Cvar iter_var)) in
|
|
let (reads, bufs) = read_lhs_of_ty lhs ty in
|
|
([Cfor (iter_var, 0, n, reads)], bufs)
|
|
| _ ->
|
|
let rec mk_prompt lhs = match lhs with
|
|
| Cvar vn -> (vn, [])
|
|
| Carray (lhs, cvn) ->
|
|
let (vn, args) = mk_prompt lhs in
|
|
(vn ^ "[%d]", cvn :: args) in
|
|
let (prompt, args_format_s) = mk_prompt lhs in
|
|
let scan_exp =
|
|
let printf_s = Printf.sprintf "%s ? " prompt in
|
|
let format_s = format_for_type ty in
|
|
Csblock { var_decls = [];
|
|
block_body = [
|
|
Csexpr (Cfun_call ("printf",
|
|
Cconst (Cstrlit printf_s)
|
|
:: args_format_s));
|
|
Csexpr (Cfun_call ("scanf",
|
|
[Cconst (Cstrlit format_s);
|
|
Caddrof lhs])); ]; } in
|
|
match need_buf_for_ty ty with
|
|
| None -> ([scan_exp], [])
|
|
| Some tyn ->
|
|
let varn = Ident.name (Ident.fresh "buf") in
|
|
([scan_exp;
|
|
Csexpr (Cfun_call (tyn ^ "_of_string",
|
|
[Clhs (Cvar varn)]))],
|
|
[(varn, Cty_arr (20, Cty_char))]) in
|
|
|
|
|
|
|
|
(** Generates printf statements and buffer declarations needed for printing
|
|
resulting values of enum types. *)
|
|
let rec write_lhs_of_ty lhs ty = match ty with
|
|
| Tarray (ty, n) ->
|
|
let iter_var = Ident.name (Ident.fresh "i") in
|
|
let lhs = Carray (lhs, Clhs (Cvar iter_var)) in
|
|
let (reads, bufs) = write_lhs_of_ty lhs ty in
|
|
(Cfor (iter_var, 0, n, [reads]), bufs)
|
|
| _ ->
|
|
let varn = Ident.name (Ident.fresh "buf") in
|
|
let format_s = format_for_type ty in
|
|
let nbuf_opt = need_buf_for_ty ty in
|
|
let ep = match nbuf_opt with
|
|
| None -> [Clhs lhs]
|
|
| Some sid -> [Cfun_call ("string_of_" ^ sid,
|
|
[Clhs lhs;
|
|
Clhs (Cvar varn)])] in
|
|
(Csexpr (Cfun_call ("printf",
|
|
Cconst (Cstrlit ("=> " ^format_s ^ "\\t"))
|
|
:: ep)),
|
|
match nbuf_opt with
|
|
| None -> []
|
|
| Some id -> [(varn, Cty_arr (20, Cty_char))]) in
|
|
|
|
let (scanf_calls, scanf_decls) =
|
|
let read_lhs_of_ty_for_vd vd =
|
|
read_lhs_of_ty (Cvar (Ident.name vd.v_name)) vd.v_type in
|
|
split (map read_lhs_of_ty_for_vd cd.step.inp) in
|
|
|
|
let (printf_calls, printf_decls) =
|
|
let write_lhs_of_ty_for_vd vd = match cd.step.out with
|
|
| [{ v_type = Tarray _; }] ->
|
|
write_lhs_of_ty (Cfield (Cvar "mem", name vd.v_name)) vd.v_type
|
|
| [_] -> write_lhs_of_ty (Cvar "res") vd.v_type
|
|
| _ ->
|
|
write_lhs_of_ty (Cfield (Cvar "mem", name vd.v_name)) vd.v_type in
|
|
split (map write_lhs_of_ty_for_vd cd.step.out) in
|
|
|
|
let cinp = cvarlist_of_ovarlist cd.step.inp in
|
|
let cout = match cd.step.out with
|
|
| [{ v_type = Tarray _; }] -> []
|
|
| [vd] -> let vty = ctype_of_otype vd.v_type in [("res", vty)]
|
|
| _ -> [] 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
|
|
(* Our function returns something only when the node has exactly one
|
|
non-array output. *)
|
|
@ ([match cd.step.out with
|
|
| [{ v_type = Tarray _; }] -> Csexpr funcall
|
|
| [_] -> Caffect (Cvar "res", funcall)
|
|
| _ -> Csexpr 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 =
|
|
let addrof { v_name = c_name } =
|
|
Caddrof (Cvar (Ident.name c_name)) in
|
|
List.map addrof 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.size <> 1 then Cty_arr (od.size, 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 ->
|
|
let name = !global_name ^ "_" ^ name in
|
|
[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 translate name prog =
|
|
let modname = (Filename.basename name) in
|
|
global_name := String.capitalize modname;
|
|
(global_file_header modname prog) :: (cfile_list_of_oprog modname prog)
|