jeltz
/
heptagon
1
0
Fork 0
Code Issues Pull Requests Releases Activity
You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
async
master
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '58086190eb'
${ noResults }
heptagon/compiler/obc/java/obc2java.ml

561 lines
24 KiB
OCaml
Raw Blame History

(***********************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Gwenael Delaval, LIG/INRIA, UJF *)
(* Leonard Gerard, Parkas, ENS *)
(* Adrien Guatto, Parkas, ENS *)
(* Cedric Pasteur, Parkas, ENS *)
(* *)
(* Copyright 2012 ENS, INRIA, UJF *)
(* *)
(* This file is part of the Heptagon compiler. *)
(* *)
(* Heptagon is free software: you can redistribute it and/or modify it *)
(* under the terms of the GNU General Public License as published by *)
(* the Free Software Foundation, either version 3 of the License, or *)
(* (at your option) any later version. *)
(* *)
(* Heptagon is distributed in the hope that it will be useful, *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
(* GNU General Public License for more details. *)
(* *)
(* You should have received a copy of the GNU General Public License *)
(* along with Heptagon. If not, see <http://www.gnu.org/licenses/> *)
(* *)
(***********************************************************************)
(** An Obc.program is a Java.package,
Obc.type_dec, Obc.class_def are Java.classs
Obc.const_dec is defined in the special class CONSTANTES
Obc.Lvar are Pvar
Obc.Lmem are this.Pvar (Pfield)
Obc.Oobj and Oarray are simply Pvar and Parray_elem
Obc.Types_alias are dereferenced since no simple type alias is possible in Java *)
(** Requires scalarized Obc :
[p = e] when [e] is an array is understand as a copy of the reference, not a copy of the array.*)
open Format
open Misc
open Names
open Modules
open Signature
open Obc
open Obc_utils
open Java
let this_field_ident id = Efield (Ethis, Idents.name id)
(** Additional classes created during the translation *)
let add_classe, get_classes =
let extra_classes = ref [] in
(fun c -> extra_classes := c :: !extra_classes)
,(fun () -> !extra_classes)
(** fresh Afor from 0 to [size]
with [body] a function from [var_ident] (the iterator) to [act] list *)
let fresh_for size body =
let i = Idents.gen_var "obc2java" "i" in
let id = mk_var_dec i false Tint in
Afor (id, Sint 0, size, mk_block (body i))
(** fresh nested Afor from 0 to [size]
with [body] a function from [var_ident] list (the iterator list) to [act] list :
s_l = [10; 20]
then
for i in 20
for j in 10
body [i][j]
*)
let fresh_nfor s_l body =
let rec aux s_l i_l = match s_l with
| [s] ->
let i = Idents.gen_var "obc2java" "i" in
let id = (mk_var_dec i false Tint) in
Afor (id, Sint 0, s, mk_block (body (List.rev (i::i_l))))
| s::s_l ->
let i = Idents.gen_var "obc2java" "i" in
let id = mk_var_dec i false Tint in
Afor (id, Sint 0, s, mk_block ([aux s_l (i::i_l)]))
| [] -> Misc.internal_error "Fresh nfor called with empty size list"
in
aux s_l []
(* current module is not translated to keep track,
there is no issue since printed without the qualifier *)
let rec translate_modul m = m (*match m with
| Pervasives
| LocalModule -> m
| _ when m = g_env.current_mod -> m
| Module n -> Module n
| QualModule { qual = q; name = n} ->
QualModule { qual = translate_modul q; name = String.lowercase n }
*)
(** a [Module.const] becomes a [module.CONSTANTES.CONST] *)
let translate_const_name { qual = m; name = n } =
{ qual = QualModule { qual = translate_modul m; name = "CONSTANTES"}; name = String.uppercase n }
(** a [Module.fun] becomes a [module.FUNS.fun] *)
let translate_fun_name { qual = m; name = n } =
{ qual = QualModule { qual = translate_modul m; name = "FUNS"}; name = n }
(** a [Module.name] becomes a [module.Name]
used for type_names, class_names, fun_names *)
let qualname_to_class_name q =
{ qual = translate_modul q.qual; name = String.capitalize q.name }
(** a [Module.name] becomes a [module.Name] even on current_mod *)
let qualname_to_package_classe q =
{ qual = translate_modul q.qual; name = String.capitalize q.name }
(** Create a fresh class qual from a name *)
let fresh_classe n = Modules.fresh_value "obc2java" n |> qualname_to_package_classe
(** a [Module.Constr] of an [Module.enum] type
becomes a [module.Enum.CONSTR] of the [module.Enum] class *)
let translate_constructor_name_2 q q_ty =
let classe = qualname_to_class_name q_ty in
{ qual = QualModule classe; name = String.uppercase q.name }
let translate_constructor_name q =
match Modules.unalias_type (Types.Tid (Modules.find_constrs q)) with
| Types.Tid q_ty when q_ty = Initial.pbool -> q |> shortname |> local_qn
| Types.Tid q_ty -> translate_constructor_name_2 q q_ty
| _ -> assert false
let translate_field_name f = f |> Names.shortname |> String.lowercase
(** a [name] becomes a [package.Name] *)
let name_to_classe_name n = n |> Modules.current_qual |> qualname_to_package_classe
(** translate an ostatic_exp into an jexp *)
let rec static_exp param_env se = match se.Types.se_desc with
| Types.Svar c ->
(match c.qual with
| LocalModule ->
let n = NamesEnv.find (shortname c) param_env in
Svar (n |> Idents.name |> local_qn)
| _ -> Svar (translate_const_name c))
| Types.Sint i -> Sint i
| Types.Sfloat f -> Sfloat f
| Types.Sbool b -> Sbool b
| Types.Sstring s -> Sstring s
| Types.Sconstructor c -> let c = translate_constructor_name c in Sconstructor c
| Types.Sfield _ -> eprintf "ojSfield @."; assert false;
| Types.Stuple se_l -> tuple param_env se_l
| Types.Sarray_power (see,pow_list) ->
let pow_list = List.rev pow_list in
let rec make_array tyl pow_list = match tyl, pow_list with
| Tarray(t, _), pow::pow_list ->
let pow = (try Static.int_of_static_exp Names.QualEnv.empty pow
with Errors.Error ->
eprintf "%aStatic power of array should have integer power. \
Please use callgraph or non-static exp in %a.@."
Location.print_location se.Types.se_loc
Global_printer.print_static_exp se;
raise Errors.Error)
in
Enew_array (tyl, Misc.repeat_list (make_array t pow_list) pow)
| _ -> static_exp param_env see
in
make_array (ty param_env se.Types.se_ty) pow_list
(*let t = match x.pat_ty with
| Tarray (t,_) -> t
| _ -> Misc.internal_error "mls2obc select slice type" 5
in
let eval_int pow = (try Static.int_of_static_exp Names.QualEnv.empty pow
with Errors.Error ->
eprintf "%aStatic power of array should have integer power. \
Please use callgraph or non-static exp in %a.@."
Location.print_location se.Types.se_loc
Global_printer.print_static_exp se;
raise Errors.Error)
in
let rec make_matrix acc = match pow_list with
| [] -> acc
| pow :: pow_list ->
let pow = eval_int pow in
make_matrix (Misc.repeat_list acc pow) pow_list
in
let se_l = match pow_list with
| [] -> Misc.internal_error "Empty power list" 0
| pow :: pow_list -> make_matrix (Misc.repeat_list (static_exp param_env see)) pow_list
in
Enew_array (ty param_env se.Types.se_ty, se_l)*)
| Types.Sarray se_l ->
Enew_array (ty param_env se.Types.se_ty, List.map (static_exp param_env) se_l)
| Types.Srecord _ -> Misc.unsupported "Srecord in java" (* TODO java *)
| Types.Sop (f, se_l) -> Efun (qualname_to_class_name f, List.map (static_exp param_env) se_l)
and boxed_ty param_env t = match Modules.unalias_type t with
| Types.Tprod [] -> Tunit
| Types.Tprod ty_l -> tuple_ty param_env ty_l
| Types.Tid t when t = Initial.pbool -> Tclass (Names.local_qn "Boolean")
| Types.Tid t when t = Initial.pint -> Tclass (Names.local_qn "Integer")
| Types.Tid t when t = Initial.pfloat -> Tclass (Names.local_qn "Float")
| Types.Tid t -> Tclass (qualname_to_class_name t)
| Types.Tarray _ ->
let rec gather_array t = match t with
| Types.Tarray (t,size) ->
let t, s_l = gather_array t in
t, (static_exp param_env size)::s_l
| _ -> ty param_env t, []
in
let t, s_l = gather_array t in
Tarray (t, s_l)
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type"
and tuple_ty param_env ty_l =
let ln = ty_l |> List.length |> Pervasives.string_of_int in
Tclass (java_pervasive_class ("Tuple"^ln))
and ty param_env t =
let t = Modules.unalias_type t in
match t with
| Types.Tprod [] -> Tunit
| Types.Tprod ty_l -> tuple_ty param_env ty_l
| Types.Tid t when t = Initial.pbool -> Tbool
| Types.Tid t when t = Initial.pint -> Tint
| Types.Tid t when t = Initial.pfloat -> Tfloat
| Types.Tid t -> Tclass (qualname_to_class_name t)
| Types.Tarray _ ->
let rec gather_array t = match t with
| Types.Tarray (t,size) ->
let tin, s_l = gather_array t in
tin, (static_exp param_env size)::s_l
| _ -> ty param_env t, []
in
let tin, s_l = gather_array t in
Tarray (tin, s_l)
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type"
and var_dec param_env vd = { vd_type = ty param_env vd.v_type;
vd_alias = vd.v_alias;
vd_ident = vd.v_ident }
and var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l
and exp param_env e = match e.e_desc with
| Obc.Eextvalue p -> ext_value param_env p
| Obc.Eop (op,e_l) -> Efun (op, exp_list param_env e_l)
| Obc.Estruct _ -> eprintf "ojEstruct@."; assert false (* TODO java *)
| Obc.Earray e_l -> Enew_array (ty param_env e.e_ty, exp_list param_env e_l)
and exp_list param_env e_l = List.map (exp param_env) e_l
and tuple param_env se_l =
let t = tuple_ty param_env (List.map (fun e -> Modules.unalias_type e.Types.se_ty) se_l) in
Enew (t, List.map (static_exp param_env) se_l)
and pattern param_env p = match p.pat_desc with
| Obc.Lvar v -> Pvar v
| Obc.Lmem v -> Pthis v
| Obc.Lfield (p,f) -> Pfield (pattern param_env p, translate_field_name f)
| Obc.Larray _ ->
let p, idx_l =
let rec gather_idx acc p = match p.pat_desc with
| Obc.Larray (p,e) -> gather_idx ((exp param_env e)::acc) p
| _ -> pattern param_env p, acc
in
let p, idx_l = gather_idx [] p in
p, idx_l
in
Parray_elem (p, idx_l)
and pattern_to_exp param_env p = match p.pat_desc with
| Obc.Lvar v -> Evar v
| Obc.Lmem v -> this_field_ident v
| Obc.Lfield (p,f) ->
Efield (pattern_to_exp param_env p, translate_field_name f)
| Obc.Larray _ ->
let p, idx_l =
let rec gather_idx acc p = match p.pat_desc with
| Obc.Larray (p,e) -> gather_idx ((exp param_env e)::acc) p
| _ -> pattern_to_exp param_env p, acc
in
let p, idx_l = gather_idx [] p in
p, idx_l
in
Earray_elem (p, idx_l)
and ext_value param_env w = match w.w_desc with
| Obc.Wvar v -> Evar v
| Obc.Wconst c -> static_exp param_env c
| Obc.Wmem v -> this_field_ident v
| Obc.Wfield (p,f) -> Efield (ext_value param_env p, translate_field_name f)
| Obc.Warray (p,e) -> Earray_elem (ext_value param_env p, [exp param_env e])
let obj_ref param_env o = match o with
| Oobj id -> Evar id
| Oarray (id, p_l) ->
(* the generated list is in java order *)
let idx_l = List.map (fun p -> pattern_to_exp param_env p) p_l in
Earray_elem (Evar id, idx_l)
let rec act_list param_env act_l acts =
let _act act acts = match act with
| Obc.Aassgn (p,e) -> (Aassgn (pattern param_env p, exp param_env e))::acts
| Obc.Aop (op,e_l) -> Aexp (Efun (op, exp_list param_env e_l)) :: acts
| Obc.Acall ([], obj, Mstep, e_l) ->
let acall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
Aexp acall::acts
| Obc.Acall ([p], obj, Mstep, e_l) ->
let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
let assgn = Aassgn (pattern param_env p, ecall) in
assgn::acts
| Obc.Acall (p_l, obj, Mstep, e_l) ->
let return_ty = p_l |> pattern_list_to_type |> (ty param_env) in
let return_id = Idents.gen_var "obc2java" "out" in
let return_vd = mk_var_dec return_id false return_ty in
let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
let assgn = Anewvar (return_vd, ecall) in
let copy_return_to_var i p =
let t = ty param_env p.pat_ty in
let cast t e = match t with
| Tbool -> Ecast(Tbool, Ecast(boxed_ty param_env p.pat_ty, e))
| Tint -> Ecast(Tint, Ecast(boxed_ty param_env p.pat_ty, e))
| Tfloat -> Ecast(Tfloat, Ecast(boxed_ty param_env p.pat_ty, e))
| _ -> Ecast(t, e)
in
let p = pattern param_env p in
Aassgn (p, cast t (Efield (Evar return_id, "c"^(string_of_int i))))
in
let copies = Misc.mapi copy_return_to_var p_l in
assgn::(copies@acts)
| Obc.Acall (_, obj, Mreset, _) ->
let acall = Emethod_call (obj_ref param_env obj, "reset", []) in
Aexp acall::acts
| Obc.Acase (e, c_b_l) when e.e_ty = Types.Tid Initial.pbool ->
(match c_b_l with
| [] -> acts
| [(c,b)] when c = Initial.ptrue ->
(Aif (exp param_env e, block param_env b)):: acts
| [(c,b)] when c = Initial.pfalse ->
(Aifelse (exp param_env e, {b_locals = []; b_body = []}, block param_env b)) :: acts
| _ ->
let _, _then = List.find (fun (c,_) -> c = Initial.ptrue) c_b_l in
let _, _else = List.find (fun (c,_) -> c = Initial.pfalse) c_b_l in
(Aifelse (exp param_env e, block param_env _then, block param_env _else)) :: acts)
| Obc.Acase (e, c_b_l) ->
let _c_b (c,b) = translate_constructor_name c, block param_env b in
let acase = Aswitch (exp param_env e, List.map _c_b c_b_l) in
acase::acts
| Obc.Afor (v, se, se', b) ->
let afor = Afor (var_dec param_env v,
exp param_env se, exp param_env se', block param_env b) in
afor::acts
| Obc.Ablock b ->
let ablock = Ablock (block param_env b) in
ablock::acts
in
List.fold_right _act act_l acts
and block param_env ?(locals=[]) ?(end_acts=[]) ob =
let blocals = var_dec_list param_env ob.Obc.b_locals in
let locals = locals @ blocals in
let acts = act_list param_env ob.Obc.b_body end_acts in
{ b_locals = locals; b_body = acts }
(** Create the [param_env] and translate [Signature.param]s to [var_dec]s
@return [vds, param_env] *)
let sig_params_to_vds p_l =
let param_to_arg param_env p =
let p_ident = Idents.gen_var "obc2java" (String.uppercase p.Signature.p_name) in
let p_vd = mk_var_dec p_ident false (ty param_env p.Signature.p_type) in
let param_env = NamesEnv.add p.Signature.p_name p_ident param_env in
p_vd, param_env
in Misc.mapfold param_to_arg NamesEnv.empty p_l
(** Translate [Signature.arg]s to [var_dec]s *)
let sig_args_to_vds param_env a_l =
let arg_to_vd { a_name = n; a_type = t } =
let n = match n with None -> "v" | Some s -> s in
let id = Idents.gen_var "obc2java" n in
mk_var_dec id false (ty param_env t)
in List.map arg_to_vd a_l
(** [copy_to_this vd_l] creates [this.x = x] for all [x] in [vd_l] *)
let copy_to_this vd_l =
let _vd vd = Aassgn (Pthis vd.vd_ident, Evar vd.vd_ident) in
List.map _vd vd_l
let class_def_list classes cd_l =
let class_def classes cd =
Idents.enter_node cd.cd_name;
let class_name = qualname_to_package_classe cd.cd_name in
(* [param_env] is an env mapping local param name to ident *)
(* [params] : fields to stock the static parameters, arguments of the constructors *)
let fields_params, vds_params, exps_params, param_env =
let v, env = sig_params_to_vds cd.cd_params in
let f = vds_to_fields ~protection:Pprotected v in
let e = vds_to_exps v in
f, v, e, env
in
(* [reset] is the reset method of the class,
[reset_mems] is the block to reset the members of the class
without call to the reset method of inner instances,
it retains [this.x = 0] but not [this.I.reset()] *)
let reset, reset_mems =
try (* When there exist a reset method *)
let oreset = find_reset_method cd in
let body = block param_env oreset.Obc.m_body in
let reset_mems = block param_env (remove_resets oreset.Obc.m_body) in
mk_methode body "reset", reset_mems
with Not_found -> (* stub reset method *)
mk_methode (mk_block []) "reset", mk_block []
in
(* [obj_env] gives the type of an [obj_ident],
needed in async because we change the classe for async obj *)
let constructeur, obj_env =
let obj_env = (* Mapping between Obc class and Java class, useful at least with asyncs *)
let aux obj_env od =
let t = Tclass (qualname_to_class_name od.o_class)
in Idents.Env.add od.o_ident t obj_env
in List.fold_left aux Idents.Env.empty cd.cd_objs
in
let body =
(* Function to initialize the objects *)
let obj_init_act acts od =
let params = List.map (static_exp param_env) od.o_params in
match od.o_size with
| None ->
let t = Idents.Env.find od.o_ident obj_env in
(Aassgn (Pthis od.o_ident, Enew (t, params)))::acts
| Some size_l ->
let size_l = List.rev (List.map (static_exp param_env) size_l) in
let t = Idents.Env.find od.o_ident obj_env in
let assgn_elem i_l =
[ Aassgn (Parray_elem (Pthis od.o_ident, List.map mk_var i_l), Enew (t, params)) ]
in
(Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size_l), [])))
:: (fresh_nfor size_l assgn_elem)
:: acts
in
(* function to allocate the arrays *)
let allocate acts vd = match Modules.unalias_type vd.v_type with
| Types.Tarray _ ->
let t = ty param_env vd.v_type in
( Aassgn (Pthis vd.v_ident, Enew_array (t,[])) ):: acts
| _ -> acts
in
(* init actions [acts] in reverse order : *)
(* init member variables *)
let acts = [Ablock reset_mems] in
(* allocate member arrays *)
let acts = List.fold_left allocate acts cd.cd_mems in
(* init member objects *)
let acts = List.fold_left obj_init_act acts cd.cd_objs in
(* init static params *)
let acts = (copy_to_this vds_params)@acts in
{ b_locals = []; b_body = acts }
in mk_methode ~args:vds_params body (shortname class_name), obj_env
in
let fields =
let mem_to_field fields vd =
(mk_field ~protection:Pprotected (ty param_env vd.v_type) vd.v_ident) :: fields
in
let obj_to_field fields od =
let jty = match od.o_size with
| None -> Idents.Env.find od.o_ident obj_env
| Some size_l -> Tarray (Idents.Env.find od.o_ident obj_env,
List.map (static_exp param_env) size_l)
in
(mk_field ~protection:Pprotected jty od.o_ident) :: fields
in
let fields = fields_params in
let fields = List.fold_left mem_to_field fields cd.cd_mems in
List.fold_left obj_to_field fields cd.cd_objs
in
let step =
let ostep = find_step_method cd in
let vd_output = var_dec_list param_env ostep.m_outputs in
let return_ty = ostep.m_outputs |> vd_list_to_type |> (ty param_env) in
let return_act =
Areturn (match vd_output with
| [] -> Evoid
| [vd] -> Evar vd.vd_ident
| vd_l -> Enew (return_ty, List.map (fun vd -> Evar vd.vd_ident) vd_l))
in
let body = block param_env ~locals:vd_output ~end_acts:[return_act] ostep.Obc.m_body in
mk_methode ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step"
in
let classe = mk_classe ~fields:fields
~constrs:[constructeur] ~methodes:[step;reset] class_name in
classe::classes
in
List.fold_left class_def classes cd_l
let type_dec_list classes td_l =
let param_env = NamesEnv.empty in
let _td classes td =
let classe_name = qualname_to_package_classe td.t_name in
Idents.enter_node classe_name;
match td.t_desc with
| Type_abs -> Misc.unsupported "obc2java, abstract type."
| Type_alias t -> (*verify that it is possible to unalias and skip it*)
let _ = Modules.unalias_type t in
classes
| Type_enum c_l ->
let mk_constr_enum c = translate_constructor_name_2 c td.t_name in
(mk_enum (List.map mk_constr_enum c_l) classe_name) :: classes
| Type_struct f_l ->
let mk_field_jfield { Signature.f_name = oname; Signature.f_type = oty } =
let jty = ty param_env oty in
let field = Idents.ident_of_name (translate_field_name oname) in
(* [translate_field_name] will give the right result anywhere it is used,
since the [ident_of_name] will keep it as it is unique in the class,
see [Idents.enter_node classe_name] *)
mk_field jty field
in
(mk_classe ~fields:(List.map mk_field_jfield f_l) classe_name) :: classes
in
List.fold_left _td classes td_l
let const_dec_list cd_l = match cd_l with
| [] -> []
| _ ->
let classe_name = "CONSTANTES" |> name_to_classe_name in
Idents.enter_node classe_name;
let param_env = NamesEnv.empty in
let mk_const_field { Obc.c_name = oname ; Obc.c_value = ovalue; Obc.c_type = otype } =
let name = oname |> translate_const_name |> shortname |> Idents.ident_of_name in
(* name should always keep the shortname unchanged
since we enter a special node free of existing variables *)
(* thus [translate_const_name] will gives the right result anywhere it is used. *)
let value = Some (static_exp param_env ovalue) in
let t = ty param_env otype in
mk_field ~static: true ~final: true ~value: value t name
in
let fields = List.map mk_const_field cd_l in
[mk_classe ~fields: fields classe_name]
let program p =
let rec program_descs pds (ns,cs,ts) = match pds with
| [] -> ns,cs,ts
| Obc.Pclass n :: pds -> program_descs pds (n::ns,cs,ts)
| Obc.Pconst c :: pds -> program_descs pds (ns,c::cs,ts)
| Obc.Ptype t :: pds -> program_descs pds (ns,cs,t::ts)
in
let ns,cs,ts = program_descs p.p_desc ([],[],[]) in
let classes = const_dec_list cs in
let classes = type_dec_list classes ts in
let p = class_def_list classes ns in
get_classes()@p
Reference in New Issue View Git Blame Copy Permalink