From dc3d564b702b7fa3189bac8c0532a1e83dec6164 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Wed, 16 Jun 2010 11:32:13 +0200 Subject: [PATCH] New Obc ast Also ported some recent fixes --- minils/sequential/cgen.ml | 912 +++++++++++++--------------- minils/sequential/java.ml | 5 + minils/sequential/mls2obc.ml | 168 +++-- minils/sequential/obc.ml | 137 ++--- minils/transformations/normalize.ml | 14 +- 5 files changed, 614 insertions(+), 622 deletions(-) diff --git a/minils/sequential/cgen.ml b/minils/sequential/cgen.ml index 9f35187..10a54b2 100644 --- a/minils/sequential/cgen.ml +++ b/minils/sequential/cgen.ml @@ -27,26 +27,31 @@ struct | 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 + output_location loc + name | Enode name -> eprintf "%aCode generation : The node name '%s' is unbound.\n" - output_location loc - name + output_location loc + name | Eno_unnamed_output -> eprintf "%aCode generation : Unnamed outputs are not supported. \n" - output_location loc + 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 struct_name = function - | Heptagon.Tid n -> n +let rec struct_name ty = + match ty with + | Cty_id n -> n | _ -> assert false let cname_of_name' name = match name with @@ -66,8 +71,9 @@ let rec print_list ff print sep l = 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 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) = @@ -77,39 +83,39 @@ let reset_opened_modules () = let shortname = function | Name(n) -> n - | Modname(q) -> - if q.qual <> "Pervasives" then - add_opened_module q.qual; + | 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 = +(** Returns the information concerning a node given by name. *) +let node_info classln = match classln with | Modname {qual = modname; id = modname_name } -> - begin try + 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 = 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 + 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 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*) + | None -> Error.message no_location Error.Eno_unnamed_output in - List.map remove_option sig_info.info.outputs + List.map remove_option sig_info.info.outputs (******************************) @@ -121,7 +127,7 @@ let output_names_list sig_info = (** [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). + 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). *) @@ -130,28 +136,28 @@ let rec ctype_of_otype oty = | 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 + 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) + 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 ty = Translate.translate_base_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 + name vd.v_name, ty in - List.map cvar_of_ovar vl + List.map cvar_of_ovar vl let copname = function | "=" -> "==" | "<>" -> "!=" | "&" -> "&&" | "or" -> "||" | "+" -> "+" @@ -161,56 +167,43 @@ let copname = function | "~-" -> "-" | "not" -> "!" | op -> op -(** Translates an Obc var_dec to a tuple (name, cty). *) +(** 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 = +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) + 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 = +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 = +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)] + | 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) + | [] -> (*Error.message no_location (Error.Evar n)*)assert false | (vn,ty)::var_env -> - if vn = n then - ty - else - assoc_type n 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 @@ -218,112 +211,131 @@ let rec assoc_type n var_env = 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 + | 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 { 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*) + let ty = assoc_type_lhs x var_env in + let n = struct_name ty in + let { info = { fields = fields } } = find_struct (longname n) in + ctype_of_heptty (List.assoc 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). *) -let rec create_affect_stm dest src ty = - match ty with +and 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)] + (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 + try let lhs = lhs_of_exp e in - match lhs with - | Carray _ -> Clhs lhs - | Cderef lhs -> Clhs lhs - | _ -> Caddrof lhs + 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 _ -> + (** 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. *) + (** 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) + | Cconst_array(n,c) -> + let cc = cexpr_of_exp var_env (Const c) in + Carraylit (repeat_list cc n) end - (** Operators *) + (** Operators *) | Op(op, exps) -> cop_of_op var_env op exps - (** Structure literals. *) + (** 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) - + let ctyn = shortname tyn in + Cstructlit (ctyn, cexps) + | ArrayLit 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 + 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 + 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; + add_opened_module m; Cfun_call(op,cexps) | Name(op) -> Cfun_call(op,cexps) -and cop_of_op var_env op_name exps = +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 + 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 -> + (** 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. *) + 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 e, cexpr_of_exp var_env 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 @@ -342,346 +354,269 @@ let rec assoc_obj instance obj_env = else assoc_obj instance t let assoc_cn instance obj_env = - (assoc_obj instance obj_env).cls + 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.*) +(** 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 = + 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] + | [] ,[] -> [] + | 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. +(** 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 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 = + 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. *) + 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) + (** 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)) + (** 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) ] + | Cconst_array(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. *) +(** [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 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. *) + (** 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 + 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 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]. *) + 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 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...*) + 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. *) + 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 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. *) + 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. *) + 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 = - (** 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 + let format_for_type ty = match ty with + | Tarray _ -> assert false + | Tint | Tid (Name "int"| Modname {qual = "Pervasives"; id = "int"}) + | Tid (Name "bool"| Modname { qual="Pervasives"; id = "bool" }) -> + "%d" + | Tfloat | Tid (Name "float"| Modname {qual = "Pervasives"; id = "int"}) -> + "%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 | Tid (Name "int"| Modname {qual = "Pervasives"; id = "int"}) + | Tid (Name "bool"| Modname { qual="Pervasives"; id = "bool" }) + | Tfloat | Tid (Name "float"| Modname {qual = "Pervasives"; id = "int"}) -> + 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 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 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) = - 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 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 = - begin match cd.step.out with - | [] -> [] - | [vd] -> [("res", ctype_of_otype vd.v_type)] - | _ -> [("res", Cty_id (cd.cl_id ^ "_res"))] - end 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 @@ -694,10 +629,15 @@ let main_def_of_class_def cd = let funcall = let args = map (fun vd -> Clhs (Cvar (name vd.v_name))) cd.step.inp - @ [Caddrof (Cvar ("mem"))] in + @ [Caddrof (Cvar "mem")] in Cfun_call (cd.cl_id ^ "_step", args) in concat scanf_calls - @ [Caffect (Cvar "res", funcall)] + (* 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 @@ -716,10 +656,10 @@ let main_def_of_class_def cd = } (** Builds the argument list of step function*) -let step_fun_args n sf = +let step_fun_args n sf = let args = cvarlist_of_ovarlist sf.inp in - args - @[("self", Cty_ptr (Cty_id (n ^ "_mem")))] + 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 @@ -746,27 +686,29 @@ let fun_def_of_step_fun name obj_env mem sf = 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 + | [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 + | [] -> 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 @@ -776,12 +718,12 @@ let fun_def_of_step_fun name obj_env mem sf = 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 + | [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*) + (** 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 @@ -807,28 +749,28 @@ let mem_decl_of_class_def cd = 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 + 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. *) + (** 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 + 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) + 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 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"); @@ -870,6 +812,7 @@ let decls_of_type_decl otd = 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, @@ -878,8 +821,8 @@ let decls_of_type_decl otd = 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)];; + 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 = @@ -920,9 +863,9 @@ let cdefs_and_cdecls_of_type_decl otd = [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 decls = List.map (fun (n,ty) -> n, ctype_of_otype ty) fl in let decl = Cdecl_struct (otd.t_name, decls) in - ([], [decl]) + ([], [decl]) (** [cfile_list_of_oprog oprog] translates the Obc program [oprog] to a list of C source and header files. *) @@ -936,23 +879,23 @@ let cfile_list_of_oprog name oprog = 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; - + 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 + (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; + 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 @@ -969,24 +912,25 @@ let cfile_list_of_oprog name oprog = 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 + 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)) - + 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 @@ -996,8 +940,10 @@ let sanitize_identifier modname id = match id with let translate name prog = let modname = (Filename.basename name) in - let prog = - Rename.rename_program (sanitize_identifier (String.capitalize modname)) prog in + global_name := String.capitalize modname; +(* let prog = + let name = sanitize_identifier (String.capitalize modname) in + Rename.rename_program name prog in *) begin match !simulation_node with | None -> () | Some s -> simulation_node := Some (String.capitalize name ^ "_" ^ s) diff --git a/minils/sequential/java.ml b/minils/sequential/java.ml index 9a540c0..3f6b7ef 100644 --- a/minils/sequential/java.ml +++ b/minils/sequential/java.ml @@ -323,6 +323,10 @@ let bool_case = function | ("false", _) :: _ -> true | _ -> false +let obj_call_to_string = function + | Context o + | Array_context (o,_) -> o + let rec print_act ff a objs avs ts single = match a with | Assgn (x, e) -> @@ -330,6 +334,7 @@ let rec print_act ff a objs avs ts single = print_asgn ff x e avs ts single; fprintf ff ";@]" | Step_ap (xs, o, es) -> + let o = obj_call_to_string o in (match xs with | [x] -> print_lhs ff x avs single; diff --git a/minils/sequential/mls2obc.ml b/minils/sequential/mls2obc.ml index 0c07e8a..6b30c4c 100644 --- a/minils/sequential/mls2obc.ml +++ b/minils/sequential/mls2obc.ml @@ -53,23 +53,43 @@ let is_op = function | Modname { qual = "Pervasives"; id = _ } -> true | _ -> false +let op_from_string op = + Modname { qual = "Pervasives"; id = op } + +let rec lhs_of_idx_list e = function + | [] -> e + | idx::l -> Array(lhs_of_idx_list e l, idx) + +(** 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] -> + Op (op_from_string "<", [idx; Const (Cint n)]) + | idx::idx_list, n::bounds -> + Op (op_from_string "&", [Op (op_from_string "<", [idx; Const (Cint n)]); + bound_check_expr idx_list bounds]) + | _, _ -> assert false + let rec translate_type const_env = function - | Minils.Tbase(btyp) -> translate_type const_env btyp + | Minils.Tbase(btyp) -> translate_base_type const_env btyp | Minils.Tprod _ -> assert false -and translate_type const_env = function +and translate_base_type const_env = function | Minils.Tint -> Tint | Minils.Tfloat -> Tfloat | Minils.Tid(id) -> Tid(id) - | Minils.Tarray(ty, n) -> Tarray (translate_type const_env ty, + | Minils.Tarray(ty, n) -> Tarray (translate_base_type const_env ty, int_of_size_exp const_env n) let rec translate_const const_env = function | Minils.Cint(v) -> Cint(v) | Minils.Cfloat(v) -> Cfloat(v) | Minils.Cconstr(c) -> Cconstr(c) - | Minils.Carray(n,c) -> - Carray(int_of_size_exp const_env n, translate_const const_env c) + | Minils.Cconst_array(n,c) -> + Cconst_array(int_of_size_exp const_env n, translate_const const_env c) let rec translate_pat map = function | Minils.Evarpat(x) -> [var_from_name map x] @@ -101,11 +121,11 @@ let rec translate const_env map (m, si, j, s) ({ Minils.e_desc = desc } as e) = Struct(type_name,f_e_list) (*Array operators*) | Minils.Earray e_list -> - Array (List.map (translate const_env map (m, si, j, s)) e_list) + ArrayLit (List.map (translate const_env map (m, si, j, s)) e_list) | Minils.Eselect (idx,e) -> let e = translate const_env map (m, si, j, s) e in - Lhs ( Array (lhs_of_exp e, - List.map (int_of_size_exp const_env) idx) ) + Lhs ( lhs_of_idx_list (lhs_of_exp e) + (List.map (fun e -> Const (Cint (int_of_size_exp const_env e))) idx) ) | _ -> Minils.Printer.print_exp stdout e; flush stdout; assert false (* [translate pat act = si, j, d, s] *) @@ -132,7 +152,7 @@ and translate_c_act_list const_env map context pat c_act_list = and comp s_list = List.fold_right (fun s rest -> Comp(s, rest)) s_list Nothing -let rec translate_eq const_env map { Minils.eq_lhs = pat; Minils.eq_rhs = e } (m, si, j, s) = +let rec translate_eq const_env map { Minils.p_lhs = pat; Minils.p_rhs = e } (m, si, j, s) = let { Minils.e_desc = desc; Minils.e_ty = ty; Minils.e_ck = ck } = e in match pat, desc with | Minils.Evarpat(n), Minils.Efby(opt_c, e) -> @@ -160,10 +180,12 @@ let rec translate_eq const_env map { Minils.eq_lhs = pat; Minils.eq_rhs = e } (m let params = List.map (int_of_size_exp const_env) params in let j = (o, encode_longname_params n params, 1) :: j in let s = - (control map ck (Step_ap(name_list, o, c_list))) :: s in + (control map ck (Step_ap(name_list, Context o, c_list))) :: s in (m, si, j, s) | pat, Minils.Eevery({ Minils.a_op = n }, params, e_list, r ) -> + let sig_info = (Modules.find_value n).info in let name_list = translate_pat map pat in + let name_list = remove_targeted_outputs sig_info.targeting name_list in let c_list = List.map (translate const_env map (m, si, j, s)) e_list in let o = gen_symbol () in let si = (Reinit(o)) :: si in @@ -171,50 +193,65 @@ let rec translate_eq const_env map { Minils.eq_lhs = pat; Minils.eq_rhs = e } (m let j = (o, encode_longname_params n params, 1) :: j in let s = (control map (Minils.Con(ck, Name("true"), r)) (Reinit(o))) :: - (control map ck (Step_ap(name_list, o, c_list))) :: s in + (control map ck (Step_ap(name_list, Context o, c_list))) :: s in (m, si, j, s) | Minils.Etuplepat(p_list), Minils.Etuple(act_list) -> List.fold_right2 - (fun pat e -> translate_eq const_env map { Minils.eq_lhs = pat; Minils.eq_rhs = e } ) + (fun pat e -> translate_eq const_env map { Minils.p_lhs = pat; Minils.p_rhs = e } ) p_list act_list (m, si, j, s) | Minils.Evarpat(x), Minils.Eselect_slice(idx1, idx2, e) -> let idx1 = int_of_size_exp const_env idx1 in let idx2 = int_of_size_exp const_env idx2 in - let idx = - let cpt = name (Ident.fresh "i") in + let cpt = Ident.fresh "i" in let e = translate const_env map (m, si, j, s) e in - let action = For( cpt, 0, idx2 - idx1 + 1, - Assgn (Array (var_from_name map x, Var cpt), - Lhs (Array (lhs_of_exp e, idx))) ) - - let action = Array_select_slice (var_from_name map x, - translate const_env map (m, si, j, s) e, - int_of_size_exp const_env idx1, - int_of_size_exp const_env idx2) in + let idx = Op(op_from_string "+", [Lhs (Var cpt); Const (Cint idx1)]) in + let action = For(cpt, 0, idx2 - idx1 + 1, + Assgn (Array (var_from_name map x, Lhs (Var cpt)), + Lhs (Array (lhs_of_exp e, idx))) ) in m, si, j, ((control map ck action)::s) | Minils.Evarpat(x), Minils.Eselect_dyn (idx, bounds, e1, e2) -> - let action = Array_select_dyn (var_from_name map x, - translate const_env map (m, si, j, s) e1, - List.map (translate const_env map (m, si, j, s)) idx, - List.map (int_of_size_exp const_env) bounds, - translate const_env map (m, si, j, s) e2 ) in + let x = var_from_name map x in + let e1 = translate const_env map (m, si, j, s) e1 in + let bounds = List.map (int_of_size_exp const_env) bounds in + let idx = List.map (translate const_env map (m, si, j, s)) idx in + let true_act = Assgn(x, Lhs (lhs_of_idx_list (lhs_of_exp e1) idx)) in + let false_act = Assgn(x, translate const_env map (m, si, j, s) e2) in + let cond = bound_check_expr idx bounds in + let action = Case(cond, [Name "true", true_act; Name "false", false_act]) in m, si, j, ((control map ck action)::s) | Minils.Evarpat(x), Minils.Eupdate (idx, e1, e2) -> let x = var_from_name map x in let copy = Assgn (x, translate const_env map (m, si, j, s) e1) in - let action = Assgn (Array (x, List.map (int_of_size_exp const_env) idx), + let idx = List.map (fun se -> Const (Cint (int_of_size_exp const_env se))) idx in + let action = Assgn (lhs_of_idx_list x idx, translate const_env map (m, si, j, s) e2) in m, si, j, ((control map ck copy)::(control map ck action)::s) | Minils.Evarpat(x), Minils.Erepeat (n, e) -> - let cpt = name (Ident.fresh "i") in + let cpt = Ident.fresh "i" in let action = For (cpt, 0, int_of_size_exp const_env n, - Assgn(Lhs (var_from_name map x, Var cpt), - translate const_env map (m, si, j, s) e) in + Assgn(Array (var_from_name map x, Lhs (Var cpt)), + translate const_env map (m, si, j, s) e) ) in m, si, j, ((control map ck action)::s) | Minils.Evarpat(x), Minils.Econcat(e1, e2) -> - let action = Array_concat (var_from_name map x, translate const_env map (m, si, j, s) e1, - translate const_env map (m, si, j, s) e2) in - m, si, j, ((control map ck action)::s) + let cpt1 = Ident.fresh "i" in + let cpt2 = Ident.fresh "i" in + let x = var_from_name map x in + (match e1.Minils.e_ty, e2.Minils.e_ty with + | Minils.Tbase(Minils.Tarray(_, n1)), Minils.Tbase(Minils.Tarray(_, n2)) -> + let e1 = translate const_env map (m, si, j, s) e1 in + let e2 = translate const_env map (m, si, j, s) e2 in + let n1 = int_of_size_exp const_env n1 in + let n2 = int_of_size_exp const_env n2 in + let a1 = For(cpt1, 0, n1, + Assgn ( Array(x, Lhs(Var cpt1)), + Lhs (Array(lhs_of_exp e1, Lhs(Var cpt1))) ) ) in + let idx = Op (op_from_string "+", [Const (Cint n1); Lhs (Var cpt2)]) in + let a2 = For(cpt2, 0, n2, + Assgn ( Array(x, idx), + Lhs (Array(lhs_of_exp e2, Lhs(Var cpt2))) ) ) in + m, si, j, (control map ck a1)::(control map ck a2)::s + | _ -> assert false + ) | pat, Minils.Eiterator(it, f, params, n, e_list, reset) -> let sig_info = (Modules.find_value f).info in let name_list = translate_pat map pat in @@ -225,7 +262,8 @@ let rec translate_eq const_env map { Minils.eq_lhs = pat; Minils.eq_rhs = e } (m let si = if is_op f then si else (Reinit(o)) :: si in let params = List.map (int_of_size_exp const_env) params in let j = (o, encode_longname_params f params, n) :: j in - let action = Array_iterate (name_list, it, o, n, c_list) in + let x = Ident.fresh "i" in + let action = translate_iterator const_env map it x name_list o sig_info n c_list in let s = (match reset with | None -> (control map ck action)::s @@ -235,9 +273,11 @@ let rec translate_eq const_env map { Minils.eq_lhs = pat; Minils.eq_rhs = e } (m ) in m, si, j, s | Minils.Evarpat(x), Minils.Efield_update (f, e1, e2) -> - let action = Field_update (var_from_name map x, translate const_env map (m,si,j,s) e1, - f, translate const_env map (m,si,j,s) e2) in - m, si, j, ((control map ck action)::s) + let x = var_from_name map x in + let copy = Assgn (x, translate const_env map (m, si, j, s) e1) in + let action = Assgn (Field(x, f), + translate const_env map (m, si, j, s) e2) in + m, si, j, ((control map ck copy)::(control map ck action)::s) | Minils.Etuplepat [], Minils.Ereset_mem(y, v, res) -> let h = Initial.ptrue, Assgn(var_from_name map y, Const (translate_const const_env v)) in let action = Case (Lhs (var_from_name map res), [h]) in @@ -246,6 +286,54 @@ let rec translate_eq const_env map { Minils.eq_lhs = pat; Minils.eq_rhs = e } (m let action = translate_act const_env map (m, si, j, s) pat e in (m, si, j, (control map ck action) :: s) +and translate_iterator const_env map it x name_list o sig_info n c_list = + match it with + | Imap -> + let c_list = List.map (fun e -> Lhs (Array(lhs_of_exp e, Lhs (Var x)))) c_list in + let name_list = List.map (fun l -> Array(l, Lhs (Var x))) name_list in + let objn = Array_context (o, Var x) in + For(x, 0, n, + Step_ap (name_list, objn, c_list)) + + | Imapfold -> + let c_list, acc_in = split_last c_list in + let c_list = List.map (fun e -> Lhs (Array(lhs_of_exp e, Lhs (Var x)))) c_list in + let objn = Array_context (o, Var x) in + + let acc_is_targeted = (is_empty name_list) + or (last_element sig_info.inputs).a_pass_by_ref in + if acc_is_targeted then ( + (* no accumulator in output; the accumulator is modified in place *) + let name_list = List.map (fun l -> Array(l, Lhs (Var x))) name_list in + For (x, 0, n, + Step_ap(name_list, objn, c_list@[acc_in])) + ) else ( + (* use the output acc as accumulator*) + let name_list, acc_out = split_last name_list in + let name_list = List.map (fun l -> Array(l, Lhs (Var x))) name_list in + Comp( Assgn(acc_out, acc_in), + For (x, 0, n, + Step_ap(name_list@[acc_out], objn, c_list@[Lhs acc_out])) ) + ) + + | Ifold -> + let c_list, acc_in = split_last c_list in + let c_list = List.map (fun e -> Lhs (Array(lhs_of_exp e, Lhs (Var x)))) c_list in + let objn = Array_context (o, Var x) in + + let acc_is_targeted = (is_empty name_list) in + if acc_is_targeted then ( + (* no accumulator in output; the accumulator is modified in place *) + For (x, 0, n, + Step_ap(name_list, objn, c_list@[acc_in])) + ) else ( + (* use the output acc as accumulator*) + let acc_out = last_element name_list in + Comp( Assgn(acc_out, acc_in), + For (x, 0, n, + Step_ap(name_list, objn, c_list@[Lhs acc_out])) ) + ) + let translate_eq_list const_env map act_list = List.fold_right (translate_eq const_env map) act_list ([], [], [], []) @@ -259,7 +347,7 @@ let obj_decl l = List.map (fun (x, t, i) -> { obj = x; cls = t; n = i }) l let translate_var_dec const_env map l = let one_var { Minils.v_name = x; Minils.v_type = t } = - { v_name = x; v_type = translate_type const_env t; v_pass_by_ref = false } + { v_name = x; v_type = translate_base_type const_env t; v_pass_by_ref = false } in (* remove unused vars *) let l = List.filter (fun { Minils.v_name = x } -> @@ -395,7 +483,7 @@ let translate_ty_def const_env { Minils.t_name = name; Minils.t_desc = tdesc } = | Minils.Type_enum(tag_name_list) -> Type_enum(tag_name_list) | Minils.Type_struct(field_ty_list) -> Type_struct - (List.map (fun (f, ty) -> (f, translate_type const_env ty)) field_ty_list) + (List.map (fun (f, ty) -> (f, translate_base_type const_env ty)) field_ty_list) in { t_name = name; t_desc = tdesc } diff --git a/minils/sequential/obc.ml b/minils/sequential/obc.ml index 2a1de98..1ce6399 100644 --- a/minils/sequential/obc.ml +++ b/minils/sequential/obc.ml @@ -23,15 +23,10 @@ type obj_name = name type op_name = longname type field_name = longname -type iterator_name = - | Imap - | Ifold - | Imapfold - - type ty = | Tint | Tfloat + | Tbool | Tid of type_name | Tarray of ty * int @@ -56,36 +51,34 @@ type lhs = | Field of lhs * field_name | Array of lhs * exp -type exp = +and exp = | Lhs of lhs | Const of const | Op of op_name * exp list | Struct of type_name * (field_name * exp) list - | Array of exp list + | ArrayLit of exp list + +type obj_call = + | Context of obj_name + | Array_context of obj_name * lhs type act = | Assgn of lhs * exp - | Step_ap of lhs list * obj_name * exp list + | Step_ap of lhs list * obj_call * exp list | Comp of act * act | Case of exp * (longname * act) list | For of var_name * int * int * act | Reinit of obj_name | Nothing - | Array_select_slice of lhs * exp * int * int - | Array_select_dyn of lhs * exp * exp list * int list * exp (* res, var, indices, bounds, def value*) - | Array_iterate of lhs list * iterator_name * obj_name * int * exp list - | Array_concat of lhs * exp * exp - | Field_update of lhs * exp * longname * exp (* var, record, field, value*) type var_dec = { v_name : var_name; - v_type : ty; - v_pass_by_ref : bool; } + v_type : ty; } type obj_dec = { obj : obj_name; cls : instance_name; - n : int; } + size : int; } type step_fun = { inp : var_dec list; @@ -114,17 +107,28 @@ type program = (** [is_scalar_type vd] returns whether the type corresponding to this variable declaration is scalar (ie a type that can be returned by a C function). *) -let is_scalar_type ty = +let is_scalar_type vd = + match vd.v_type with + | Tint | Tfloat -> true + | Tid name_int when name_int = pint -> true + | Tid name_float when name_float = pfloat -> true + | Tid name_bool when name_bool = pbool -> true + | _ -> false + +let actual_type ty = match ty with - | Tid x -> - (x = Initial.pint) or (x = Initial.pfloat) or (x = Initial.pbool) - | _ -> false + | Tid(Name("float")) + | Tid(Modname { qual = "Pervasives"; id = "float" }) -> Tfloat + | Tid(Name("int")) + | Tid(Modname { qual = "Pervasives"; id = "int" }) -> Tint + | _ -> ty let rec var_name x = match x with | Var x -> x | Mem x -> x | Field(x,_) -> var_name x + | Array(l, _) -> var_name l (** Returns whether an object of name n belongs to a list of var_dec. *) @@ -202,7 +206,7 @@ struct print_type ff vd.v_type; fprintf ff "@]" - let print_obj ff { cls = cls; obj = obj; n = n } = + let print_obj ff { cls = cls; obj = obj; size = n } = fprintf ff "@["; print_name ff obj; fprintf ff " : "; print_longname ff cls; if n <> 1 then @@ -222,8 +226,13 @@ struct | Var x -> print_ident ff x | Mem x -> fprintf ff "mem("; print_ident ff x; fprintf ff ")" | Field (l, f) -> print_lhs ff l; fprintf ff ".%s" (shortname f) + | Array(x, idx) -> + print_lhs ff x; + fprintf ff "["; + print_exp ff idx; + fprintf ff "]" - let rec print_exps ff e_list = print_list ff print_exp "," e_list + and print_exps ff e_list = print_list ff print_exp "," e_list and print_exp ff = function | Lhs lhs -> print_lhs ff lhs @@ -236,15 +245,10 @@ struct print_exp ff e) ";" f_e_list; fprintf ff "}@]" - | Array e_list -> + | ArrayLit e_list -> fprintf ff "@[["; print_list ff print_exp ";" e_list; fprintf ff "]@]" - | Array_select(x, idx) -> - print_exp ff x; - fprintf ff "["; - print_list ff (fun ff -> fprintf ff "%d") "][" idx; - fprintf ff "]" and print_op ff op e_list = print_longname ff op; @@ -256,6 +260,13 @@ struct fprintf ff "@["; print_exp ff e; fprintf ff "@]"; fprintf ff "@]" + let print_obj_call ff = function + | Context o -> print_name ff o + | Array_context (o, i) -> + fprintf ff "%a[%a]" + print_name o + print_lhs i + let rec print_act ff a = match a with | Assgn (x, e) -> print_asgn ff "" x e @@ -270,78 +281,20 @@ struct print_exp ff e; fprintf ff ") {@,"; print_tag_act_list ff tag_act_list; fprintf ff "@]@,}@]" + | For(x, i1, i2, act) -> + fprintf ff "@[@[for %s=%d to %d : {@, %a @]@,}@]" + (name x) i1 i2 + print_act act | Step_ap (var_list, o, es) -> fprintf ff "@[("; print_list ff print_lhs "," var_list; fprintf ff "@])"; - fprintf ff " = "; print_name ff o; fprintf ff ".step("; + fprintf ff " = "; print_obj_call ff o; fprintf ff ".step("; fprintf ff "@["; print_exps ff es; fprintf ff "@]"; fprintf ff ")" | Reinit o -> print_name ff o; fprintf ff ".reset()" | Nothing -> fprintf ff "()" - | Array_select_slice (var, e, idx1, idx2) -> - fprintf ff "@["; - print_lhs ff var; - fprintf ff " = "; - print_exp ff e; - fprintf ff "[%d..%d]" idx1 idx2; - fprintf ff "@]" - | Array_select_dyn (var, x, idx, _, defe) -> - fprintf ff "@["; - print_lhs ff var; - fprintf ff " = "; - fprintf ff "@["; - print_exp ff x; - fprintf ff "["; - print_list ff print_exp "][" idx; - fprintf ff "] default "; - print_exp ff defe; - fprintf ff "@]" - | Array_update (x, e1, idx, e2) -> - fprintf ff "@["; - print_lhs ff x; - fprintf ff " = "; - print_exp ff e1; - fprintf ff " with ["; - print_list ff (fun ff -> fprintf ff "%d") "][" idx; - fprintf ff "] = "; - print_exp ff e2; - fprintf ff "@]" - | Array_repeat (x, n, e) -> - fprintf ff "@["; - print_lhs ff x; - fprintf ff " = "; - print_exp ff e; - fprintf ff "^%d" n - | Array_iterate (o_list, it, f, n, e_list) -> - fprintf ff "@[("; - print_list ff print_lhs ", " o_list; - fprintf ff ") = "; - fprintf ff "("; - fprintf ff "%s" (iterator_to_string it); - fprintf ff " "; - print_name ff f; - fprintf ff " <<%d>>) (@[" n; - print_list ff print_exp "," e_list; - fprintf ff ")@]@]" - | Array_concat (x, e1, e2) -> - fprintf ff "@["; - print_lhs ff x; - fprintf ff " = "; - print_exp ff e1; - fprintf ff " @@ "; - print_exp ff e2 - | Field_update (x, e1, f, e2) -> - fprintf ff "@["; - print_lhs ff x; - fprintf ff " = "; - print_exp ff e1; - fprintf ff " with ."; - print_longname ff f; - fprintf ff " = "; - print_exp ff e2; - fprintf ff "@]" and print_tag_act_list ff tag_act_list = print_list ff diff --git a/minils/transformations/normalize.ml b/minils/transformations/normalize.ml index 4afc3ba..d6979b8 100644 --- a/minils/transformations/normalize.ml +++ b/minils/transformations/normalize.ml @@ -20,8 +20,8 @@ and cfalse = Name("false") let equation (d_list, eq_list) ({ e_ty = te; e_linearity = l; e_ck = ck } as e) = let n = Ident.fresh "_v" in let d_list = { v_name = n; v_copy_of = None; - v_type = type te; v_linearity = l; v_clock = ck } :: d_list - and eq_list = { eq_lhs = Evarpat(n); eq_rhs = e } :: eq_list in + v_type = base_type te; v_linearity = l; v_clock = ck } :: d_list + and eq_list = { p_lhs = Evarpat(n); p_rhs = e } :: eq_list in (d_list, eq_list), n let intro context e = @@ -113,8 +113,8 @@ let rec constant e = match e.e_desc with let add context expected_kind ({ e_desc = de; e_linearity = l } as e) = let up = match de, expected_kind with | (Evar _ | Efield _ ) , VRefCond -> false - | Efby _, VRefCond -> true - | _ , VRefCond -> not (Linearity.is_not_linear l) + | Econst _ , VRefCond -> not (Linearity.is_not_linear l) + | _, VRefCond -> true | (Evar _ | Efield _ ) , VRef -> false | _ , VRef -> true | ( Emerge _ | Etuple _ @@ -232,17 +232,17 @@ let rec translate_eq context pat e = | Evarpat(x), Efby _ when not (vd_mem x d_list) -> let (d_list, eq_list), n = equation context e in d_list, - { eq_lhs = pat; eq_rhs = { e with e_desc = Evar(n) } } :: eq_list + { p_lhs = pat; p_rhs = { e with e_desc = Evar(n) } } :: eq_list | Etuplepat(pat_list), Etuple(e_list) -> List.fold_left2 distribute context pat_list e_list - | _ -> d_list, { eq_lhs = pat; eq_rhs = e } :: eq_list in + | _ -> d_list, { p_lhs = pat; p_rhs = e } :: eq_list in let context, e = translate Any context e in distribute context pat e let translate_eq_list d_list eq_list = List.fold_left - (fun context { eq_lhs = pat; eq_rhs = e } -> translate_eq context pat e) + (fun context { p_lhs = pat; p_rhs = e } -> translate_eq context pat e) (d_list, []) eq_list let translate_contract ({ c_eq = eq_list; c_local = d_list } as c) =