jeltz
/
heptagon
1
0
Fork 0
Code Issues Pull Requests Releases Activity

again

Browse Source
master
Léonard Gérard 14 years ago
parent df469db394
commit 09419a77a5
21 changed files with 346 additions and 226 deletions
Show Stats Download Patch File Download Diff File

1
compiler/global/global_printer.ml
Unescape Escape View File

@ -48,6 +48,7 @@ and print_static_exp_tuple ff l =
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
and print_type ff = function and print_type ff = function
| Tprod [] -> fprintf ff "INVALID TYPE"
| Tprod ty_list -> | Tprod ty_list ->
fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
| Tid id -> print_qualname ff id | Tid id -> print_qualname ff id

10
compiler/global/initial.ml
Unescape Escape View File

@ -15,22 +15,26 @@ let tglobal = []
let cglobal = [] let cglobal = []
let pbool = { qual = "Pervasives"; name = "bool" } let pbool = { qual = "Pervasives"; name = "bool" }
let tbool = Types.Tid pbool
let ptrue = { qual = "Pervasives"; name = "true" } let ptrue = { qual = "Pervasives"; name = "true" }
let pfalse = { qual = "Pervasives"; name = "false" } let pfalse = { qual = "Pervasives"; name = "false" }
let por = { qual = "Pervasives"; name = "or" } let por = { qual = "Pervasives"; name = "or" }
let pint = { qual = "Pervasives"; name = "int" } let pint = { qual = "Pervasives"; name = "int" }
let tint = Types.Tid pint
let pfloat = { qual = "Pervasives"; name = "float" } let pfloat = { qual = "Pervasives"; name = "float" }
let tfloat = Types.Tid pfloat
let mk_pervasives s = { qual = "Pervasives"; name = s } let mk_pervasives s = { qual = "Pervasives"; name = s }
let mk_static_int_op op args = let mk_static_int_op op args =
mk_static_exp ~ty:(Tid pint) (Sop (op,args)) mk_static_exp ~ty:tint (Sop (op,args))
let mk_static_int i = let mk_static_int i =
mk_static_exp ~ty:(Tid pint) (Sint i) mk_static_exp ~ty:tint (Sint i)
let mk_static_bool b = let mk_static_bool b =
mk_static_exp ~ty:(Tid pbool) (Sbool b) mk_static_exp ~ty:tbool (Sbool b)

5
compiler/global/types.ml
Unescape Escape View File

@ -42,6 +42,11 @@ let prod = function
| [ty] -> ty | [ty] -> ty
| ty_list -> Tprod ty_list | ty_list -> Tprod ty_list
let unprod = function
| Tprod l -> l
| t -> [t]
let asyncify async ty_list = match async with let asyncify async ty_list = match async with
| None -> ty_list | None -> ty_list
| Some a -> List.map (fun ty -> Tasync (a,ty)) ty_list | Some a -> List.map (fun ty -> Tasync (a,ty)) ty_list

214
compiler/main/mls2obc.ml
Unescape Escape View File

@ -19,21 +19,29 @@ open Obc_mapfold
open Initial open Initial
let fresh_it () = Idents.gen_var "mls2obc" "i" let fresh_it () =
let id = Idents.gen_var "mls2obc" "i" in
id, mk_var_dec id Initial.tint
let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst") let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst")
let op_from_string op = { qual = "Pervasives"; name = op; } let op_from_string op = { qual = "Pervasives"; name = op; }
let rec lhs_of_idx_list e = function let rec pattern_of_idx_list p l =
| [] -> e | idx :: l -> mk_lhs (Larray (lhs_of_idx_list e l, idx)) let rec aux ty l = match ty, l with
| _, [] -> p
| Tarray (ty',_), idx :: l -> mk_pattern ty (Larray (aux ty' l, idx))
| _ -> internal_error "mls2obc" 1
in
aux p.pat_ty l
let array_elt_of_exp idx e = let array_elt_of_exp idx e =
match e.e_desc with match e.e_desc, Modules.unalias_type e.e_ty with
| Econst ({ se_desc = Sarray_power (c, _) }) -> | Econst ({ se_desc = Sarray_power (c, _) }), Tarray (ty,_) ->
mk_exp (Econst c) mk_exp ty (Econst c)
| _ -> | _, Tarray (ty,_) ->
mk_lhs_exp (Larray(lhs_of_exp e, mk_exp (Elhs idx))) mk_pattern_exp ty (Larray(pattern_of_exp e, mk_exp Initial.tint (Epattern idx)))
| _ -> internal_error "mls2obc" 2
(** Creates the expression that checks that the indices (** Creates the expression that checks that the indices
in idx_list are in the bounds. If idx_list=[e1;..;ep] in idx_list are in the bounds. If idx_list=[e1;..;ep]
@ -41,15 +49,11 @@ let array_elt_of_exp idx e =
e1 <= n1 && .. && ep <= np *) e1 <= n1 && .. && ep <= np *)
let rec bound_check_expr idx_list bounds = let rec bound_check_expr idx_list bounds =
match (idx_list, bounds) with match (idx_list, bounds) with
| [idx], [n] -> | [idx], [n] -> mk_exp_bool (Eop (op_from_string "<", [idx; mk_exp_int (Econst n)]))
mk_exp (Eop (op_from_string "<",
[idx; mk_exp (Econst n)]))
| (idx :: idx_list, n :: bounds) -> | (idx :: idx_list, n :: bounds) ->
let e = mk_exp (Eop (op_from_string "<", let e = mk_exp_bool (Eop (op_from_string "<", [idx; mk_exp_int (Econst n)])) in
[idx; mk_exp (Econst n)])) in mk_exp_bool (Eop (op_from_string "&", [e; bound_check_expr idx_list bounds]))
mk_exp (Eop (op_from_string "&", | (_, _) -> internal_error "mls2obc" 3
[e; bound_check_expr idx_list bounds]))
| (_, _) -> assert false
let reinit o = let reinit o =
Acall ([], o, Mreset, []) Acall ([], o, Mreset, [])
@ -70,7 +74,7 @@ let translate_var_dec l =
let rec translate map e = let rec translate map e =
let desc = match e.Minils.e_desc with let desc = match e.Minils.e_desc with
| Minils.Econst v -> Econst v | Minils.Econst v -> Econst v
| Minils.Evar n -> Elhs (Control.var_from_name map n) | Minils.Evar n -> Epattern (Control.var_from_name map n)
| Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) -> | Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) ->
Eop (op_from_string "=", List.map (translate map ) e_list) Eop (op_from_string "=", List.map (translate map ) e_list)
| Minils.Eapp ({ Minils.a_op = Minils.Efun n }, e_list, _) when Mls_utils.is_op n -> | Minils.Eapp ({ Minils.a_op = Minils.Efun n }, e_list, _) when Mls_utils.is_op n ->
@ -85,17 +89,17 @@ let rec translate map e =
let f_e_list = List.map (fun (f, e) -> (f, (translate map e))) f_e_list in let f_e_list = List.map (fun (f, e) -> (f, (translate map e))) f_e_list in
Estruct (type_name, f_e_list) Estruct (type_name, f_e_list)
| Minils.Eapp ({ Minils.a_op = Minils.Efield; Minils.a_params = params }, e_list, _) -> | Minils.Eapp ({ Minils.a_op = Minils.Efield; Minils.a_params = params }, e_list, _) ->
let f = match (assert_1 params).se_desc with Sfield f -> f | _ -> assert false in let f = match (assert_1 params).se_desc with Sfield f -> f | _ -> internal_error "mls2obc" 4 in
let e = translate map (assert_1 e_list) in let e = translate map (assert_1 e_list) in
Elhs (mk_lhs (Lfield (lhs_of_exp e, f))) Epattern (mk_pattern e.e_ty (Lfield (pattern_of_exp e, f)))
(*Remaining array operators*) (*Remaining array operators*)
| Minils.Eapp ({ Minils.a_op = Minils.Earray }, e_list, _) -> | Minils.Eapp ({ Minils.a_op = Minils.Earray }, e_list, _) ->
Earray (List.map (translate map ) e_list) Earray (List.map (translate map ) e_list)
| Minils.Eapp ({ Minils.a_op = Minils.Eselect; | Minils.Eapp ({ Minils.a_op = Minils.Eselect;
Minils.a_params = idx }, e_list, _) -> Minils.a_params = idx }, e_list, _) ->
let e = translate map (assert_1 e_list) in let e = translate map (assert_1 e_list) in
let idx_list = List.map (fun idx -> mk_exp (Econst idx)) idx in let idx_list = List.map (fun idx -> mk_exp tint (Econst idx)) idx in
Elhs (lhs_of_idx_list (lhs_of_exp e) idx_list) Epattern (pattern_of_idx_list (pattern_of_exp e) idx_list)
(* Async operators *) (* Async operators *)
| Minils.Eapp ({Minils.a_op = Minils.Ebang }, e_list, _) -> | Minils.Eapp ({Minils.a_op = Minils.Ebang }, e_list, _) ->
let e = translate map (assert_1 e_list) in let e = translate map (assert_1 e_list) in
@ -105,11 +109,12 @@ let rec translate map e =
| Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat|Minils.Eupdate|Minils.Eselect_dyn | Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat|Minils.Eupdate|Minils.Eselect_dyn
|Minils.Eselect_slice|Minils.Earray_fill|Minils.Efield_update|Minils.Eifthenelse |Minils.Eselect_slice|Minils.Earray_fill|Minils.Efield_update|Minils.Eifthenelse
|Minils.Etuple)}, _, _) -> |Minils.Etuple)}, _, _) ->
Format.eprintf "%aThis should not be treated as an exp in mls2obc : %a@." (*Format.eprintf "%aThis should not be treated as an exp in mls2obc : %a@."
Location.print_location e.Minils.e_loc Mls_printer.print_exp e; Location.print_location e.Minils.e_loc Mls_printer.print_exp e;
assert false assert false*)
internal_error "mls2obc" 5
in in
mk_exp ~ty:e.Minils.e_ty desc mk_exp e.Minils.e_ty desc
(* [translate pat act = si, d] *) (* [translate pat act = si, d] *)
and translate_act map pat and translate_act map pat
@ -124,54 +129,53 @@ and translate_act map pat
| pat, Minils.Ewhen (e, _, _) -> | pat, Minils.Ewhen (e, _, _) ->
translate_act map pat e translate_act map pat e
| pat, Minils.Emerge (x, c_act_list) -> | pat, Minils.Emerge (x, c_act_list) ->
let lhs = Control.var_from_name map x in let pattern = Control.var_from_name map x in
[Acase (mk_exp (Elhs lhs), translate_c_act_list map pat c_act_list)] [Acase (mk_exp pattern.pat_ty (Epattern pattern), translate_c_act_list map pat c_act_list)]
(* Array ops *) (* Array ops *)
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) -> | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) ->
let cpt1 = fresh_it () in let cpt1, cpt1d = fresh_it () in
let cpt2 = fresh_it () in let cpt2, cpt2d = fresh_it () in
let x = Control.var_from_name map x in let x = Control.var_from_name map x in
let t = x.pat_ty in
(match e1.Minils.e_ty, e2.Minils.e_ty with (match e1.Minils.e_ty, e2.Minils.e_ty with
| Tarray (_, n1), Tarray (_, n2) -> | Tarray (t1, n1), Tarray (t2, n2) ->
let e1 = translate map e1 in let e1 = translate map e1 in
let e2 = translate map e2 in let e2 = translate map e2 in
let a1 = let a1 =
Afor (cpt1, mk_static_int 0, n1, Afor (cpt1d, mk_static_int 0, n1,
mk_block [Aassgn (mk_lhs (Larray (x, mk_evar cpt1)), mk_block [Aassgn (mk_pattern t (Larray (x, mk_evar_int cpt1)),
mk_lhs_exp (Larray (lhs_of_exp e1, mk_pattern_exp t1 (Larray (pattern_of_exp e1, mk_evar_int cpt1)))] ) in
mk_evar cpt1)))] ) in let idx = mk_exp_int (Eop (op_from_string "+", [ mk_exp_int (Econst n1); mk_evar_int cpt2])) in
let idx = mk_exp (Eop (op_from_string "+",
[ mk_exp (Econst n1); mk_evar cpt2])) in
let a2 = let a2 =
Afor (cpt2, mk_static_int 0, n2, Afor (cpt2d, mk_static_int 0, n2,
mk_block [Aassgn (mk_lhs (Larray (x, idx)), mk_block [Aassgn (mk_pattern t (Larray (x, idx)),
mk_lhs_exp (Larray (lhs_of_exp e2, mk_pattern_exp t2 (Larray (pattern_of_exp e2, mk_evar_int cpt2)))] )
mk_evar cpt2)))] )
in in
[a1; a2] [a1; a2]
| _ -> assert false ) | _ -> assert false )
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = [n] }, [e], _) -> | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = [n] }, [e], _) ->
let cpt = fresh_it () in let cpt, cptd = fresh_it () in
let e = translate map e in let e = translate map e in
[ Afor (cpt, mk_static_int 0, n, let x = Control.var_from_name map x in
mk_block [Aassgn (mk_lhs (Larray (Control.var_from_name map x, mk_evar cpt)), e) ]) ] [ Afor (cptd, mk_static_int 0, n, mk_block [Aassgn (mk_pattern x.pat_ty (Larray (x, mk_evar_int cpt)), e) ]) ]
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; Minils.a_params = [idx1; idx2] }, [e], _) -> | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; Minils.a_params = [idx1; idx2] }, [e], _) ->
let cpt = fresh_it () in let cpt, cptd = fresh_it () in
let e = translate map e in let e = translate map e in
let idx = mk_exp (Eop (op_from_string "+", [mk_evar cpt; mk_exp (Econst idx1) ])) in let x = Control.var_from_name map x in
let idx = mk_exp_int (Eop (op_from_string "+", [mk_evar_int cpt; mk_exp_int (Econst idx1) ])) in
(* bound = (idx2 - idx1) + 1*) (* bound = (idx2 - idx1) + 1*)
let bound = mk_static_int_op (op_from_string "+") let bound = mk_static_int_op (op_from_string "+")
[ mk_static_int 1; mk_static_int_op (op_from_string "-") [idx2;idx1] ] in [ mk_static_int 1; mk_static_int_op (op_from_string "-") [idx2;idx1] ] in
[ Afor (cpt, mk_static_int 0, bound, [ Afor (cptd, mk_static_int 0, bound,
mk_block [Aassgn (mk_lhs (Larray (Control.var_from_name map x, mk_evar cpt)), mk_block [Aassgn (mk_pattern x.pat_ty (Larray (x, mk_evar_int cpt)),
mk_lhs_exp (Larray (lhs_of_exp e, idx)))] ) ] mk_pattern_exp e.e_ty (Larray (pattern_of_exp e, idx)))] ) ]
| Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) -> | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) ->
let x = Control.var_from_name map x in let x = Control.var_from_name map x in
let bounds = Mls_utils.bounds_list e1.Minils.e_ty in let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
let e1 = translate map e1 in let e1 = translate map e1 in
let idx = List.map (translate map) idx in let idx = List.map (translate map) idx in
let true_act = let p = pattern_of_idx_list (pattern_of_exp e1) idx in
Aassgn (x, mk_exp (Elhs (lhs_of_idx_list (lhs_of_exp e1) idx))) in let true_act = Aassgn (x, mk_exp p.pat_ty (Epattern p)) in
let false_act = Aassgn (x, translate map e2) in let false_act = Aassgn (x, translate map e2) in
let cond = bound_check_expr idx bounds in let cond = bound_check_expr idx bounds in
[ Acase (cond, [ ptrue, mk_block [true_act]; pfalse, mk_block [false_act] ]) ] [ Acase (cond, [ ptrue, mk_block [true_act]; pfalse, mk_block [false_act] ]) ]
@ -179,7 +183,7 @@ and translate_act map pat
let x = Control.var_from_name map x in let x = Control.var_from_name map x in
let bounds = Mls_utils.bounds_list e1.Minils.e_ty in let bounds = Mls_utils.bounds_list e1.Minils.e_ty in
let idx = List.map (translate map) idx in let idx = List.map (translate map) idx in
let action = Aassgn (lhs_of_idx_list x idx, let action = Aassgn (pattern_of_idx_list x idx,
translate map e2) in translate map e2) in
let cond = bound_check_expr idx bounds in let cond = bound_check_expr idx bounds in
let action = Acase (cond, [ ptrue, mk_block [action] ]) in let action = Acase (cond, [ ptrue, mk_block [action] ]) in
@ -190,8 +194,8 @@ and translate_act map pat
Minils.Eapp ({ Minils.a_op = Minils.Efield_update; Minils.a_params = [{ se_desc = Sfield f }] }, [e1; e2], _) -> Minils.Eapp ({ Minils.a_op = Minils.Efield_update; Minils.a_params = [{ se_desc = Sfield f }] }, [e1; e2], _) ->
let x = Control.var_from_name map x in let x = Control.var_from_name map x in
let copy = Aassgn (x, translate map e1) in let copy = Aassgn (x, translate map e1) in
let action = Aassgn (mk_lhs (Lfield (x, f)), translate map e2) in let action = Aassgn (mk_pattern x.pat_ty (Lfield (x, f)), translate map e2) in
[copy; action] [copy; action]
| Minils.Evarpat n, _ -> | Minils.Evarpat n, _ ->
[Aassgn (Control.var_from_name map n, translate map act)] [Aassgn (Control.var_from_name map n, translate map act)]
@ -233,7 +237,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
let x = Control.var_from_name map n in let x = Control.var_from_name map n in
let si = (match opt_c with let si = (match opt_c with
| None -> si | None -> si
| Some c -> (Aassgn (x, mk_exp (Econst c))) :: si) in | Some c -> (Aassgn (x, mk_exp x.pat_ty (Econst c))) :: si) in
let action = Aassgn (Control.var_from_name map n, translate map e) in let action = Aassgn (Control.var_from_name map n, translate map e) in
v, si, j, (Control.control map ck action) :: s v, si, j, (Control.control map ck action) :: s
@ -258,12 +262,10 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
pfalse, mk_block ~locals:vf false_act]) in pfalse, mk_block ~locals:vf false_act]) in
v, si, j, (Control.control map ck action) :: s v, si, j, (Control.control map ck action) :: s
| pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app, | pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app, e_list, r) ->
e_list, r) ->
let name_list = translate_pat map pat in let name_list = translate_pat map pat in
let c_list = List.map (translate map) e_list in let c_list = List.map (translate map) e_list in
let v', si', j', action = mk_node_call map call_context let v', si', j', action = mk_node_call map call_context app loc name_list c_list e.Minils.e_ty in
app loc name_list c_list in
let action = List.map (Control.control map ck) action in let action = List.map (Control.control map ck) action in
let s = (match r, app.Minils.a_op with let s = (match r, app.Minils.a_op with
| Some r, Minils.Enode _ -> | Some r, Minils.Enode _ ->
@ -275,12 +277,10 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
| pat, Minils.Eiterator (it, app, n, e_list, reset) -> | pat, Minils.Eiterator (it, app, n, e_list, reset) ->
let name_list = translate_pat map pat in let name_list = translate_pat map pat in
let c_list = let c_list = List.map (translate map) e_list in
List.map (translate map) e_list in let x, xd = fresh_it () in
let x = fresh_it () in let call_context = Some { oa_index = mk_pattern_int (Lvar x); oa_size = n} in
let call_context = Some { oa_index = mk_lhs (Lvar x); oa_size = n} in let si', j', action = translate_iterator map call_context it name_list app loc n x xd c_list e.Minils.e_ty in
let si', j', action = translate_iterator map call_context it
name_list app loc n x c_list in
let action = List.map (Control.control map ck) action in let action = List.map (Control.control map ck) action in
let s = let s =
(match reset, app.Minils.a_op with (match reset, app.Minils.a_op with
@ -299,18 +299,18 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e }
and translate_eq_list map call_context act_list = and translate_eq_list map call_context act_list =
List.fold_right (translate_eq map call_context) act_list ([], [], [], []) List.fold_right (translate_eq map call_context) act_list ([], [], [], [])
and mk_node_call map call_context app loc name_list args = and mk_node_call map call_context app loc name_list args ty =
match app.Minils.a_op with match app.Minils.a_op with
| Minils.Efun f when Mls_utils.is_op f -> | Minils.Efun f when Mls_utils.is_op f ->
let e = mk_exp (Eop(f, args)) in let e = mk_exp ty (Eop(f, args)) in
[], [], [], [Aassgn(List.hd name_list, e) ] [], [], [], [Aassgn(List.hd name_list, e)]
| Minils.Enode f when Itfusion.is_anon_node f -> | Minils.Enode f when Itfusion.is_anon_node f ->
let add_input env vd = Env.add vd.Minils.v_ident (mk_lhs (Lvar vd.Minils.v_ident)) env in let add_input env vd = Env.add vd.Minils.v_ident (mk_pattern vd.Minils.v_type (Lvar vd.Minils.v_ident)) env in
let build env vd a = Env.add vd.Minils.v_ident a env in let build env vd a = Env.add vd.Minils.v_ident a env in
let subst_act_list env act_list = let subst_act_list env act_list =
let exp funs env e = match e.e_desc with let exp funs env e = match e.e_desc with
| Elhs { pat_desc = Lvar x } -> | Epattern { pat_desc = Lvar x } ->
let e = let e =
(try Env.find x env (try Env.find x env
with Not_found -> e) in with Not_found -> e) in
@ -346,61 +346,66 @@ and mk_node_call map call_context app loc name_list args =
[], si, [obj], s [], si, [obj], s
| _ -> assert false | _ -> assert false
and translate_iterator map call_context it name_list app loc n x c_list = and translate_iterator map call_context it name_list app loc n x xd c_list ty =
let array_of_output name_list = let unarray ty = match ty with
List.map (fun l -> mk_lhs (Larray (l, mk_evar x))) name_list in | Tarray (t,_) -> t
let array_of_input c_list = | _ -> Format.eprintf "%a" Global_printer.print_type ty; internal_error "mls2obc" 6
List.map (array_elt_of_exp (mk_lhs (Lvar x))) c_list in in
let array_of_output name_list ty_list =
List.map (fun l -> mk_pattern ty (Larray (l, mk_evar_int x))) name_list (* TODO not ty, but Tprod (ti...) -> ti *)
in
let array_of_input c_list = List.map (array_elt_of_exp (mk_pattern_int (Lvar x))) c_list in
match it with match it with
| Minils.Imap -> | Minils.Imap ->
let c_list = array_of_input c_list in let c_list = array_of_input c_list in
let name_list = array_of_output name_list in let ty_list = Types.unprod ty in
let v, si, j, action = mk_node_call map call_context let name_list = array_of_output name_list ty_list in
app loc name_list c_list in let node_out_ty = Types.prod (List.map unarray ty_list) in
let v, si, j, action = mk_node_call map call_context app loc name_list c_list node_out_ty in
let v = translate_var_dec v in let v = translate_var_dec v in
let b = mk_block ~locals:v action in let b = mk_block ~locals:v action in
si, j, [ Afor (x, mk_static_int 0, n, b) ] si, j, [ Afor (xd, mk_static_int 0, n, b) ]
| Minils.Imapfold -> | Minils.Imapfold ->
let (c_list, acc_in) = split_last c_list in let (c_list, acc_in) = split_last c_list in
let c_list = array_of_input c_list in let c_list = array_of_input c_list in
let ty_list = Types.unprod ty in
let (name_list, acc_out) = split_last name_list in let (name_list, acc_out) = split_last name_list in
let name_list = array_of_output name_list in let name_list = array_of_output name_list ty_list in
let v, si, j, action = mk_node_call map call_context let node_out_ty = Types.prod (Misc.map_butlast unarray ty_list) in
app loc (name_list @ [ acc_out ]) let v, si, j, action = mk_node_call map call_context app loc (name_list @ [ acc_out ])
(c_list @ [ mk_exp (Elhs acc_out) ]) in (c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) node_out_ty
in
let v = translate_var_dec v in let v = translate_var_dec v in
let b = mk_block ~locals:v action in let b = mk_block ~locals:v action in
si, j, [Aassgn (acc_out, acc_in); si, j, [Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b)]
Afor (x, mk_static_int 0, n, b)]
| Minils.Ifold -> | Minils.Ifold ->
let (c_list, acc_in) = split_last c_list in let (c_list, acc_in) = split_last c_list in
let c_list = array_of_input c_list in let c_list = array_of_input c_list in
let acc_out = last_element name_list in let acc_out = last_element name_list in
let v, si, j, action = mk_node_call map call_context let v, si, j, action =
app loc name_list (c_list @ [ mk_exp (Elhs acc_out) ]) in mk_node_call map call_context app loc name_list (c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty
in
let v = translate_var_dec v in let v = translate_var_dec v in
let b = mk_block ~locals:v action in let b = mk_block ~locals:v action in
si, j, [ Aassgn (acc_out, acc_in); si, j, [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ]
Afor (x, mk_static_int 0, n, b) ]
| Minils.Ifoldi -> | Minils.Ifoldi ->
let (c_list, acc_in) = split_last c_list in let (c_list, acc_in) = split_last c_list in
let c_list = array_of_input c_list in let c_list = array_of_input c_list in
let acc_out = last_element name_list in let acc_out = last_element name_list in
let v, si, j, action = mk_node_call map call_context let v, si, j, action = mk_node_call map call_context app loc name_list
app loc name_list (c_list @ [ mk_evar x; mk_exp (Elhs acc_out) ]) in (c_list @ [ mk_evar_int x; mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty
in
let v = translate_var_dec v in let v = translate_var_dec v in
let b = mk_block ~locals:v action in let b = mk_block ~locals:v action in
si, j, [ Aassgn (acc_out, acc_in); si, j, [ Aassgn (acc_out, acc_in); Afor (xd, mk_static_int 0, n, b) ]
Afor (x, mk_static_int 0, n, b) ]
let remove m d_list = let remove m d_list =
List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n m)) d_list List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n m)) d_list
let translate_contract map mem_vars = let translate_contract map mem_var_tys =
function function
| None -> ([], [], [], []) | None -> ([], [], [], [])
| Some | Some
@ -408,23 +413,22 @@ let translate_contract map mem_vars =
Minils.c_eq = eq_list; Minils.c_eq = eq_list;
Minils.c_local = d_list; Minils.c_local = d_list;
} -> } ->
let (v, si, j, s_list) = translate_eq_list map let (v, si, j, s_list) = translate_eq_list map empty_call_context eq_list in
empty_call_context eq_list in
let d_list = translate_var_dec (v @ d_list) in let d_list = translate_var_dec (v @ d_list) in
let d_list = List.filter let d_list = List.filter
(fun vd -> not (List.mem vd.v_ident mem_vars)) d_list in (fun vd -> not (List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys)) d_list in
(si, j, s_list, d_list) (si, j, s_list, d_list)
(** Returns a map, mapping variables names to the variables (** Returns a map, mapping variables names to the variables
where they will be stored. *) where they will be stored. *)
let subst_map inputs outputs locals mems = let subst_map inputs outputs locals mem_tys =
(* Create a map that simply maps each var to itself *) (* Create a map that simply maps each var to itself *)
let m = let map =
List.fold_left List.fold_left
(fun m { Minils.v_ident = x } -> Env.add x (mk_lhs (Lvar x)) m) (fun m { Minils.v_ident = x; Minils.v_type = ty } -> Env.add x (mk_pattern ty (Lvar x)) m)
Env.empty (inputs @ outputs @ locals) Env.empty (inputs @ outputs @ locals)
in in
List.fold_left (fun m x -> Env.add x (mk_lhs (Lmem x)) m) m mems List.fold_left (fun map (x, x_ty) -> Env.add x (mk_pattern x_ty (Lmem x)) map) map mem_tys
let translate_node let translate_node
({ ({
@ -438,15 +442,15 @@ let translate_node
Minils.n_loc = loc; Minils.n_loc = loc;
} as n) = } as n) =
Idents.enter_node f; Idents.enter_node f;
let mem_vars = Mls_utils.node_memory_vars n in let mem_var_tys = Mls_utils.node_memory_vars n in
let subst_map = subst_map i_list o_list d_list mem_vars in let subst_map = subst_map i_list o_list d_list mem_var_tys in
let (v, si, j, s_list) = translate_eq_list subst_map empty_call_context eq_list in let (v, si, j, s_list) = translate_eq_list subst_map empty_call_context eq_list in
let (si', j', s_list', d_list') = translate_contract subst_map mem_vars contract in let (si', j', s_list', d_list') = translate_contract subst_map mem_var_tys contract in
let i_list = translate_var_dec i_list in let i_list = translate_var_dec i_list in
let o_list = translate_var_dec o_list in let o_list = translate_var_dec o_list in
let d_list = translate_var_dec (v @ d_list) in let d_list = translate_var_dec (v @ d_list) in
let m, d_list = List.partition let m, d_list = List.partition
(fun vd -> List.mem vd.v_ident mem_vars) d_list in (fun vd -> List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys) d_list in
let s = Control.joinlist (s_list @ s_list') in let s = Control.joinlist (s_list @ s_list') in
let j = j' @ j in let j = j' @ j in
let si = Control.joinlist (si @ si') in let si = Control.joinlist (si @ si') in

2
compiler/minils/main/mls2seq.ml
Unescape Escape View File

@ -39,7 +39,7 @@ let write_obc_file p =
comment "Generation of Obc code" comment "Generation of Obc code"
let targets = [ (*"c", Obc_no_params Cmain.program;*) let targets = [ (*"c", Obc_no_params Cmain.program;*)
"java", Obc_no_params Java_main.program; "java", Obc Java_main.program;
"obc", Obc write_obc_file; "obc", Obc write_obc_file;
"obc_np", Obc_no_params write_obc_file; "obc_np", Obc_no_params write_obc_file;
"epo", Minils write_object_file ] "epo", Minils write_object_file ]

7
compiler/minils/mls_utils.ml
Unescape Escape View File

@ -135,10 +135,15 @@ struct
| _ -> [] | _ -> []
end end
(* Assumes normal form, all fby are solo rhs *)
let node_memory_vars n = let node_memory_vars n =
let eq _ acc ({ eq_lhs = pat; eq_rhs = e } as eq) = let eq _ acc ({ eq_lhs = pat; eq_rhs = e } as eq) =
match e.e_desc with match e.e_desc with
| Efby(_, _) -> eq, Vars.vars_pat acc pat | Efby(_, _) ->
let v_l = Vars.vars_pat [] pat in
let t_l = Types.unprod e.e_ty in
let acc = (List.combine v_l t_l) @ acc in
eq, acc
| _ -> eq, acc | _ -> eq, acc
in in
let funs = { Mls_mapfold.defaults with eq = eq } in let funs = { Mls_mapfold.defaults with eq = eq } in

4
compiler/obc/c/cgen.ml
Unescape Escape View File

@ -274,7 +274,7 @@ let rec cexpr_of_static_exp se =
let rec cexpr_of_exp var_env exp = let rec cexpr_of_exp var_env exp =
match exp.e_desc with match exp.e_desc with
(** Obj expressions that form valid C lhs are translated via clhs_of_exp. *) (** Obj expressions that form valid C lhs are translated via clhs_of_exp. *)
| Elhs _ -> | Epattern _ ->
Clhs (clhs_of_exp var_env exp) Clhs (clhs_of_exp var_env exp)
(** Constants, the easiest translation. *) (** Constants, the easiest translation. *)
| Econst lit -> | Econst lit ->
@ -338,7 +338,7 @@ and clhss_of_lhss var_env lhss =
List.map (clhs_of_lhs var_env) lhss List.map (clhs_of_lhs var_env) lhss
and clhs_of_exp var_env exp = match exp.e_desc with and clhs_of_exp var_env exp = match exp.e_desc with
| Elhs l -> clhs_of_lhs var_env l | Epattern l -> clhs_of_lhs var_env l
(** We were passed an expression that is not translatable to a valid C lhs?!*) (** 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" | _ -> invalid_arg "clhs_of_exp: argument not a Var, Mem or Field"

4
compiler/obc/control.ml
Unescape Escape View File

@ -38,12 +38,12 @@ let rec control map ck s =
| Cvar { contents = Clink ck } -> control map ck s | Cvar { contents = Clink ck } -> control map ck s
| Con(ck, c, n) -> | Con(ck, c, n) ->
let x = var_from_name map n in let x = var_from_name map n in
control map ck (Acase(mk_exp (Elhs x), [(c, mk_block [s])])) control map ck (Acase(mk_exp x.pat_ty (Epattern x), [(c, mk_block [s])]))
let is_deadcode = function let is_deadcode = function
| Aassgn (lhs, e) -> | Aassgn (lhs, e) ->
(match e.e_desc with (match e.e_desc with
| Elhs l -> l = lhs | Epattern l -> l = lhs
| _ -> false | _ -> false
) )
| Acase (_, []) -> true | Acase (_, []) -> true

12
compiler/obc/java/java.ml
Unescape Escape View File

@ -68,15 +68,15 @@ and act = Anewvar of var_dec * exp
| Aif of exp * block | Aif of exp * block
| Aifelse of exp * block * block | Aifelse of exp * block * block
| Ablock of block | Ablock of block
| Afor of var_ident * exp * exp * block | Afor of var_dec * exp * exp * block (* TODO var_dec *)
| Areturn of exp | Areturn of exp
and exp = Eval of pattern and exp = Eval of pattern
| Efun of op_name * exp list | Efun of op_name * exp list
| Emethod_call of pattern * method_name * exp list | Emethod_call of pattern * method_name * exp list
| Enew of ty * exp list | Enew of ty * exp list
| Enew_array of ty * exp list
| Evoid (*printed as nothing*) | Evoid (*printed as nothing*)
| Earray of exp list
| Svar of const_name | Svar of const_name
| Sint of int | Sint of int
| Sfloat of float | Sfloat of float
@ -90,6 +90,14 @@ and pattern = Pfield of pattern * field_name
type program = classe list type program = classe list
let mk_var x = Eval (Pvar x)
let mk_var_dec x ty =
{ vd_type = ty; vd_ident = x }
let mk_block ?(locals=[]) b =
{ b_locals = locals; b_body = b; }
let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit) let mk_methode ?(protection=Ppublic) ?(static=false) ?(args=[]) ?(returns=Tunit)
body name = body name =
{ m_protection = protection; m_static = static; m_name = name; m_args = args; m_returns = returns; m_body = body; } { m_protection = protection; m_static = static; m_name = name; m_args = args; m_returns = returns; m_body = body; }

8
compiler/obc/java/java_main.ml
Unescape Escape View File

@ -2,10 +2,12 @@
open Java open Java
open Java_printer open Java_printer
open Obc2java open Obc2java
open Compiler_utils
let program p = let program p =
let filename = filename_of_module p in let filename = filename_of_name p.Obc.p_modname in
let dirname = build_path filename in let dirname = build_path (filename ^ "_java") in
let dir = clean_dir dirname in let dir = clean_dir dirname in
Java.print dir o let p_java = Obc2java.program p in
output_program dir p_java

35
compiler/obc/java/java_printer.ml
Unescape Escape View File

@ -13,6 +13,8 @@ open Java
open Pp_tools open Pp_tools
open Format open Format
(* TODO java faire des vrais qualname recursifs, bare_constructor doit être vraiment bare *)
let class_name = Global_printer.print_shortname let class_name = Global_printer.print_shortname
let obj_ident = Global_printer.print_ident let obj_ident = Global_printer.print_ident
let constructor_name = Global_printer.print_qualname let constructor_name = Global_printer.print_qualname
@ -54,22 +56,22 @@ let rec field ff f =
final f.f_final final f.f_final
ty f.f_type ty f.f_type
field_ident f.f_name field_ident f.f_name
(print_opt2 exp " =@ ") f.f_value (print_opt2 exp " = ") f.f_value
and exp ff = function and exp ff = function
| Eval p -> pattern ff p | Eval p -> pattern ff p
| Efun (f,e_l) -> fprintf ff "%a@[%a@]" op_name f args e_l | Efun (f,e_l) -> fprintf ff "%a@[%a@]" op_name f args e_l
| Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" pattern o method_name m args e_l | Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" pattern o method_name m args e_l
| Enew (c,e_l) -> fprintf ff "new %a%a" ty c args e_l | Enew (c,e_l) -> fprintf ff "new %a%a" ty c args e_l
| Enew_array (t,e_l) -> fprintf ff "new %a@[<2>%a@]" ty t (print_list_r exp "{"",""}") e_l
| Evoid -> () | Evoid -> ()
| Earray e_l -> fprintf ff "@[<2>%a@]" (print_list_r exp "{"",""}") e_l
| Svar c -> const_name ff c | Svar c -> const_name ff c
| Sint i -> pp_print_int ff i | Sint i -> pp_print_int ff i
| Sfloat f -> pp_print_float ff f | Sfloat f -> pp_print_float ff f
| Sbool b -> pp_print_bool ff b | Sbool b -> pp_print_bool ff b
| Sconstructor c -> constructor_name ff c | Sconstructor c -> constructor_name ff c
and args ff e_l = fprintf ff "@[%a@]" (print_list_r exp "("","")") e_l and args ff e_l = fprintf ff "@[(%a)@]" (print_list_r exp """,""") e_l
and pattern ff = function and pattern ff = function
| Pfield (p,f) -> fprintf ff "%a.%a" pattern p field_name f | Pfield (p,f) -> fprintf ff "%a.%a" pattern p field_name f
@ -100,29 +102,37 @@ and act ff = function
block bf block bf
| Ablock b -> fprintf ff "@[<2>{@ %a@ }]" block b | Ablock b -> fprintf ff "@[<2>{@ %a@ }]" block b
| Afor (x, i1, i2, b) -> | Afor (x, i1, i2, b) ->
fprintf ff "@[<2>for %a = %a to %a {@ %a@ }@]" fprintf ff "@[<2>for (%a = %a; %a<%a; %a++) {@ %a@ }@]"
var_ident x var_dec x
exp i1 exp i1
var_ident x.vd_ident
exp i2 exp i2
var_ident x.vd_ident
block b block b
| Areturn e -> fprintf ff "return %a" exp e | Areturn e -> fprintf ff "return %a" exp e
let methode ff m = let methode ff m =
fprintf ff "@[<4>%a%a%a %a @[<2>%a@] {@\n%a@]@\n}" fprintf ff "@[<4>%a%a%a %a @[<2>(%a)@] {@\n%a@]@\n}"
protection m.m_protection protection m.m_protection
static m.m_static static m.m_static
ty m.m_returns ty m.m_returns
method_name m.m_name method_name m.m_name
(vd_list "("","")") m.m_args (vd_list """,""") m.m_args
block m.m_body
let constructor ff m =
fprintf ff "@[<4>%a%a @[<2>(%a)@] {@\n%a@]@\n}"
protection m.m_protection
method_name m.m_name
(vd_list """,""") m.m_args
block m.m_body block m.m_body
let rec class_desc ff cd = let rec class_desc ff cd =
let pm = print_list methode """""" in
fprintf ff "@[<v>%a@ %a@ %a@ %a@]" fprintf ff "@[<v>%a@ %a@ %a@ %a@]"
(print_list_r field """;"";") cd.cd_fields (print_list_r field """;"";") cd.cd_fields
(print_list_r classe """""") cd.cd_classs (print_list_r classe """""") cd.cd_classs
pm cd.cd_constructors (print_list constructor """""") cd.cd_constructors
pm cd.cd_methodes (print_list methode """""") cd.cd_methodes
and classe ff c = match c.c_kind with and classe ff c = match c.c_kind with
| Cenum c_l -> | Cenum c_l ->
@ -143,8 +153,11 @@ let output_classe dir c =
let file_name = file_name ^ ".java" in let file_name = file_name ^ ".java" in
let oc = open_out (Filename.concat dir file_name) in let oc = open_out (Filename.concat dir file_name) in
let ff = Format.formatter_of_out_channel oc in let ff = Format.formatter_of_out_channel oc in
fprintf ff "package %s;@\n" package_name; fprintf ff "package %s;@\n" (String.lowercase package_name);
classe ff c; classe ff c;
pp_print_flush ff (); pp_print_flush ff ();
close_out oc close_out oc
let output_program dir (p:Java.program) =
List.iter (output_classe dir) p

174
compiler/obc/java/obc2java.ml
Unescape Escape View File

@ -24,6 +24,16 @@ open Obc
open Java open Java
let fresh_it () =
let id = Idents.gen_var "obc2java" "i" in
id, mk_var_dec id Tint
(** 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, id = fresh_it () in
Afor (id, Sint 0, size, mk_block (body i))
(** a [Module] becomes a [package] *) (** a [Module] becomes a [package] *)
let translate_qualname q = match q with let translate_qualname q = match q with
| { qual = "Pervasives" } -> q | { qual = "Pervasives" } -> q
@ -33,9 +43,9 @@ let translate_qualname q = match q with
| _ -> { q with qual = String.lowercase q.qual } | _ -> { q with qual = String.lowercase q.qual }
(** a [Module.const] becomes a [module.CONSTANTES.CONST] *) (** a [Module.const] becomes a [module.CONSTANTES.CONST] *)
let translate_const_name q = let translate_const_name q = match q with
let q = translate_qualname q in | { qual = m } when m = local_qualname -> { q with name = String.uppercase q.name }
{ qual = q.qual ^ ".CONSTANTES"; name = String.uppercase q.name } | _ -> { q with qual = (String.lowercase q.qual)^ ".CONSTANTES"; name = String.uppercase q.name }
(** a [Module.name] becomes a [module.Name] (** a [Module.name] becomes a [module.Name]
used for type_names, class_names, fun_names *) used for type_names, class_names, fun_names *)
@ -44,17 +54,19 @@ let qualname_to_class_name q =
{ q with name = String.capitalize q.name } { q with name = String.capitalize q.name }
(** a [Module.Constr] of an [Module.enum] type becomes a [module.Enum.CONSTR] of the [module.Enum] class *) (** a [Module.Constr] of an [Module.enum] type becomes a [module.Enum.CONSTR] of the [module.Enum] class *)
let _translate_constructor_name q q_ty = let _translate_constructor_name q q_ty = (* TODO java recursive qualname ! *)
let classe = qualname_to_class_name q_ty in let classe = qualname_to_class_name q_ty in
let classe_name = classe.qual ^ "." ^ classe.name in let q = qualname_to_class_name q in
let constr = { qual = classe_name; name = q |> shortname |> String.uppercase } in { q with name = classe.name ^ "." ^ q.name }
constr
let translate_constructor_name q = let translate_constructor_name q =
match Modules.find_constrs c with match Modules.find_constrs q with
| Tid c_ty -> _translate_constructor_name q q_ty | Types.Tid q_ty when q_ty = Initial.pbool -> q |> shortname |> local_qn
| Types.Tid q_ty -> _translate_constructor_name q q_ty
| _ -> assert false | _ -> assert false
let translate_field_name f = f |> Names.shortname |> String.lowercase
(** a [name] becomes a [package.Name] *) (** a [name] becomes a [package.Name] *)
let name_to_classe_name n = n |> Modules.current_qual |> qualname_to_class_name let name_to_classe_name n = n |> Modules.current_qual |> qualname_to_class_name
@ -68,16 +80,17 @@ let rec static_exp param_env se = match se.Types.se_desc with
| Types.Sfloat f -> Sfloat f | Types.Sfloat f -> Sfloat f
| Types.Sbool b -> Sbool b | Types.Sbool b -> Sbool b
| Types.Sconstructor c -> let c = translate_constructor_name c in Sconstructor c | Types.Sconstructor c -> let c = translate_constructor_name c in Sconstructor c
| Types.Sfield f -> assert false; | Types.Sfield f -> eprintf "ojSfield @."; assert false;
| Types.Stuple t -> assert false; (* TODO java ?? not too dificult if needed, return Tuplen<..>() *) | Types.Stuple t -> eprintf "ojStuple@."; assert false;
| Types.Sarray_power _ -> assert false; (* TODO java array *) (* TODO java ?? not too difficult if needed, return Tuplen<..>() *)
| Types.Sarray se_l -> Earray (List.map (static_exp param_env) se_l) | Types.Sarray_power _ -> eprintf "ojSarray_power@."; assert false; (* TODO java array *)
| Types.Srecord _ -> assert false; (* TODO java *) | Types.Sarray se_l -> Enew_array (ty param_env se.Types.se_ty, List.map (static_exp param_env) se_l)
| Types.Srecord _ -> eprintf "ojSrecord@."; assert false; (* TODO java *)
| Types.Sop (f, se_l) -> Efun (qualname_to_class_name f, List.map (static_exp param_env) se_l) | 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 t with and boxed_ty param_env t = match t with
| Types.Tprod ty_l -> | Types.Tprod ty_l ->
let ln = ty_l |> List.length |> Pervasives.char_of_int |> (String.make 1) in let ln = ty_l |> List.length |> Pervasives.string_of_int in
Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l) Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l)
| Types.Tid t when t = Initial.pbool -> Tclass (Names.local_qn "Boolean") | 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.pint -> Tclass (Names.local_qn "Integer")
@ -89,7 +102,7 @@ and boxed_ty param_env t = match t with
and ty param_env t :Java.ty = match t with and ty param_env t :Java.ty = match t with
| Types.Tprod ty_l -> | Types.Tprod ty_l ->
let ln = ty_l |> List.length |> Pervasives.char_of_int |> (String.make 1) in let ln = ty_l |> List.length |> Pervasives.string_of_int in
Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l) Tgeneric ({ qual = "heptagon"; name = "Tuple"^ln }, List.map (boxed_ty param_env) ty_l)
| Types.Tid t when t = Initial.pbool -> Tbool | Types.Tid t when t = Initial.pbool -> Tbool
| Types.Tid t when t = Initial.pint -> Tint | Types.Tid t when t = Initial.pint -> Tint
@ -99,42 +112,80 @@ and ty param_env t :Java.ty = match t with
| Types.Tasync _ -> assert false; (* TODO async *) | Types.Tasync _ -> assert false; (* TODO async *)
| Types.Tunit -> Tunit | Types.Tunit -> Tunit
let var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident }
let var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l
let rec exp param_env e = match e.e_desc with
| Obc.Epattern p -> Eval (pattern param_env p)
| Obc.Econst se -> static_exp param_env se
| 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)
| Obc.Ebang _ -> eprintf "ojEbang@."; assert false (* TODO java async *)
let var_dec_list param_env vd_l = and exp_list param_env e_l = List.map (exp param_env) e_l
let _vd vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } in
List.map _vd vd_l
let act_list param_env act_l = and pattern param_env p = match p.pat_desc with
let _act acts act = match act 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 (p,e) -> Parray_elem (pattern param_env p, exp param_env e)
let obj_ref param_env o = match o with
| Oobj id -> Pvar id
| Oarray (id,p) -> Parray_elem (Pvar id, Eval (pattern param_env p))
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.Aassgn (p,e) -> (Aassgn (pattern param_env p, exp param_env e))::acts
| Obc.Acall ([], obj, Mstep, e_l) -> | Obc.Acall ([], obj, Mstep, e_l) ->
let acall = Amethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in let acall = Amethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
acall::acts acall::acts
| Obc.Acall ([p], obj, Mstep, e_l) -> | 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 ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) in
let assgn = Aassgn (pattern param_env p, call) in let assgn = Aassgn (pattern param_env p, ecall) in
assgn::acts assgn::acts
| Obc.Acall (p_l, obj, _, e_l) -> | Obc.Acall (p_l, obj, Mstep, e_l) ->
let return_ty = p_l |> pattern_list_to_type |> (ty param_env) in let return_ty = p_l |> pattern_list_to_type |> (ty param_env) in
let return_id = Idents.gen_var "obc2java" "out" in let return_id = Idents.gen_var "obc2java" "out" in
let return_vd = { vd_type = return_ty; vd_ident = return_id } in let return_vd = { vd_type = return_ty; vd_ident = return_id } in
let ecall = Emethod_call (obj_ref param_env obj, "step", exp_list param_env e_l) 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 assgn = Anewvar (return_vd, ecall) in
let copies = Misc.mapi (fun i p -> Aassgn (p, Eval (Pfield (return_id, "c"^(string_of_int i))))) p_l in let copy_return_to_var i p =
Aassgn (pattern param_env p, Eval (Pfield (Pvar return_id, "c"^(string_of_int i))))
in
let copies = Misc.mapi copy_return_to_var p_l in
assgn::(copies@acts) assgn::(copies@acts)
| Obc.Acall (_, obj, Mreset, _) -> | Obc.Acall (_, obj, Mreset, _) ->
let acall = Amethod_call (obj_ref param_env obj, "step", []) in let acall = Amethod_call (obj_ref param_env obj, "reset", []) in
acall::acts acall::acts
| Obc.Async_call _ -> assert false (* TODO java async *) | Obc.Aasync_call _ -> assert false (* TODO java async *)
| 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,b) -> c = Initial.ptrue) c_b_l in
let _, _else = List.find (fun (c,b) -> 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) -> | Obc.Acase (e, c_b_l) ->
let _c_b (c,b) = translate_constructor_name let _c_b (c,b) = translate_constructor_name c, block param_env b in
Aswitch (exp param_env e, 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, static_exp param_env se, static_exp param_env se', block param_env b) in
afor::acts
in
List.fold_right _act act_l acts
let block param_env ?(locals=[]) ?(end_acts=[]) ob = and block param_env ?(locals=[]) ?(end_acts=[]) ob =
let blocals = var_dec_list param_env ob.Obc.b_locals in let blocals = var_dec_list param_env ob.Obc.b_locals in
let locals = locals @ blocals in let locals = locals @ blocals in
let bacts = act_list param_env ob.Obc.b_body in let acts = act_list param_env ob.Obc.b_body end_acts in
let acts = end_acts @ bacts in
{ b_locals = locals; b_body = acts } { b_locals = locals; b_body = acts }
let class_def_list classes cd_l = let class_def_list classes cd_l =
@ -144,7 +195,7 @@ let class_def_list classes cd_l =
(* [param_env] is an env mapping local param name to ident *) (* [param_env] is an env mapping local param name to ident *)
let constructeur, param_env = let constructeur, param_env =
let param_to_arg param_env p = let param_to_arg param_env p =
let p_ident = Idents.gen_var "obc2java" p.Signature.p_name in let p_ident = Idents.gen_var "obc2java" (String.uppercase p.Signature.p_name) in
let p_vd = { vd_ident = p_ident; vd_type = ty param_env p.Signature.p_type } in let p_vd = { vd_ident = p_ident; vd_type = ty param_env p.Signature.p_type } in
let param_env = NamesEnv.add p.Signature.p_name p_ident param_env in let param_env = NamesEnv.add p.Signature.p_name p_ident param_env in
p_vd, param_env p_vd, param_env
@ -156,11 +207,16 @@ let class_def_list classes cd_l =
let obj_init_act acts od = let obj_init_act acts od =
let params = List.map (static_exp param_env) od.o_params in let params = List.map (static_exp param_env) od.o_params in
let act = match od.o_size with let act = match od.o_size with
| None -> Aassgn (Pthis od.o_ident, Enew (Tclass od.o_class, params)) | None -> [ Aassgn (Pthis od.o_ident, Enew (Tclass od.o_class, params)) ]
| Some size -> assert false; (* TODO java : | Some size ->
Aassgn (Pthis od.o_ident, Enew ( Tarray, Earray [Enew (Tclass, params)... ] ) ) cf node.java*) let size = static_exp param_env size in
let assgn_elem i =
[ Aassgn (Parray_elem (Pthis od.o_ident, mk_var i), Enew (Tclass od.o_class, params)) ]
in
[ Aassgn (Pthis od.o_ident, Enew (Tarray (Tclass od.o_class,size), []));
fresh_for size assgn_elem ]
in in
act::acts act@acts
in in
let acts = List.map final_field_init_act args in let acts = List.map final_field_init_act args in
let acts = List.fold_left obj_init_act acts cd.cd_objs in let acts = List.fold_left obj_init_act acts cd.cd_objs in
@ -170,7 +226,7 @@ let class_def_list classes cd_l =
in in
let fields = let fields =
let mem_to_field fields vd = (mk_field ~protection:Pprotected (ty param_env vd.v_type) vd.v_ident) :: fields in 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 = (* TODO [o_params] are treated in the [reset] code *) let obj_to_field fields od =
let jty = match od.o_size with let jty = match od.o_size with
| None -> Tclass (qualname_to_class_name od.o_class) | None -> Tclass (qualname_to_class_name od.o_class)
| Some size -> Tarray (Tclass (qualname_to_class_name od.o_class), static_exp param_env size) | Some size -> Tarray (Tclass (qualname_to_class_name od.o_class), static_exp param_env size)
@ -194,61 +250,53 @@ let class_def_list classes cd_l =
| [vd] -> Eval (Pvar vd.vd_ident) | [vd] -> Eval (Pvar vd.vd_ident)
| vd_l -> Enew (return_ty, List.map (fun vd -> Eval (Pvar vd.vd_ident)) vd_l)) | vd_l -> Enew (return_ty, List.map (fun vd -> Eval (Pvar vd.vd_ident)) vd_l))
in in
let body = block param_env ~locals:vd_output ~end_acts:[return_act] ostep.m_body in let body = block param_env ~locals:vd_output ~end_acts:[return_act] ostep.Obc.m_body in
mk_methode ~args:(var_dec_list ostep.m_inputs) ~returns:jreturn_ty body "step" mk_methode ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step"
in in
let reset = let reset =
let oreset = find_reset_method cd in let oreset = find_reset_method cd in
let body = block param_env oreset.m_body in let body = block param_env oreset.Obc.m_body in
mk_methode body "reset" mk_methode body "reset"
in in
let classe = mk_classe ~fields=fields ~constrs=[constructeur] ~methodes=[step;reset] class_name in let classe = mk_classe ~fields:fields ~constrs:[constructeur] ~methodes:[step;reset] class_name in
classe::classes classe::classes
in in
List.fold_left classe_def classes cd_l List.fold_left class_def classes cd_l
let type_dec_list classes td_l = let type_dec_list classes td_l =
let param_env = NamesEnv.empty in let param_env = NamesEnv.empty in
let _td classes td = let _td classes td =
let classe_name = td.t_name |> qualname_to_class_name |> Names.shortname in let classe_name = qualname_to_class_name td.t_name in
let classe, jty = match td.t_desc with match td.t_desc with
| Type_abs -> eprintf "Abstract types not supported in Java backend"; assert false (* TODO java *) | Type_abs -> Misc.unsupported "obc2java" 1 (* TODO java *)
| Type_alias ot -> classes | Type_alias ot -> classes (* TODO java alias ?? *)
| Type_enum c_l -> | Type_enum c_l ->
let mk_constr_enum oc = let mk_constr_enum c = _translate_constructor_name c td.t_name in
let jc = _translate_constructor_name oc td.t_name in (mk_enum (List.map mk_constr_enum c_l) classe_name) :: classes
add_constr_name oc jc;
jc
in
(mk_enum (List.map mk_constr_enum oc_l) classe_name) :: classes
| Type_struct f_l -> | Type_struct f_l ->
let mk_field_jfield { f_name = oname; f_type = oty } = let mk_field_jfield { Signature.f_name = oname; Signature.f_type = oty } =
let jty = ty param_env oty in let jty = ty param_env oty in
let name = oname |> Names.shortname |> String.lowercase in let field = Idents.ident_of_name (translate_field_name oname) in (* TODO java pretty ugly *)
add_Field_name oname name; mk_field jty field
mk_field jty name
in in
(mk_classe ~fields:(List.map mk_field_jfield f_l) classe_name) :: classes (mk_classe ~fields:(List.map mk_field_jfield f_l) classe_name) :: classes
in
add_type_name td.t_name jty;
classes
in in
List.fold_left classes _td List.fold_left _td classes td_l
let const_dec_list cd_l = let const_dec_list cd_l =
let param_env = NamesEnv.empty in let param_env = NamesEnv.empty in
let mk_const_field { Obc.c_name = oname ; Obc.c_value = ovalue; Obc.c_type = otype } = let mk_const_field { Obc.c_name = oname ; Obc.c_value = ovalue; Obc.c_type = otype } =
let name = oname |> translate_const_name |> shortname in let name = oname |> translate_const_name |> shortname |> Idents.ident_of_name in (* TODO java pretty ugly*)
let value = static_exp ovalue in let value = Some (static_exp param_env ovalue) in
let t = ty param_env otype in let t = ty param_env otype in
mk_field ~static:true ~final:true ~value:value t name mk_field ~static:true ~final:true ~value:value t name
in in
match cd_l with match cd_l with
| [] -> [] | [] -> []
| _ -> | _ ->
let classe_name = "CONSTANTES" |> name_to_classe_name |> shortname in let classe_name = "CONSTANTES" |> name_to_classe_name in
let fields = List.map mk_const_field cd_l in let fields = List.map mk_const_field cd_l in
[mk_classe ~fields:fields classe_name] [mk_classe ~fields:fields classe_name]

2
compiler/obc/java/old_java.ml
Unescape Escape View File

@ -202,7 +202,7 @@ let rec print_lhs ff e avs single =
let rec print_exp ff e p avs ts single = let rec print_exp ff e p avs ts single =
match e.e_desc with match e.e_desc with
| Elhs l -> print_lhs ff l avs single | Epattern l -> print_lhs ff l avs single
| Econst c -> print_const ff c ts | Econst c -> print_const ff c ts
| Eop (op, es) -> print_op ff op es p avs ts single | Eop (op, es) -> print_op ff op es p avs ts single
| Estruct (type_name,fields) -> | Estruct (type_name,fields) ->

40
compiler/obc/obc.ml
Unescape Escape View File

@ -48,7 +48,7 @@ and pat_desc =
and exp = { e_desc : exp_desc; e_ty : ty; e_loc : location } and exp = { e_desc : exp_desc; e_ty : ty; e_loc : location }
and exp_desc = and exp_desc =
| Elhs of pattern | Epattern of pattern
| Econst of static_exp | Econst of static_exp
| Eop of op_name * exp list | Eop of op_name * exp list
| Estruct of type_name * (field_name * exp) list | Estruct of type_name * (field_name * exp) list
@ -68,7 +68,7 @@ type act =
| Acall of pattern list * obj_ref * method_name * exp list | Acall of pattern list * obj_ref * method_name * exp list
| Aasync_call of async_t * pattern list * obj_ref * method_name * exp list | Aasync_call of async_t * pattern list * obj_ref * method_name * exp list
| Acase of exp * (constructor_name * block) list | Acase of exp * (constructor_name * block) list
| Afor of var_ident * static_exp * static_exp * block | Afor of var_dec * static_exp * static_exp * block
and block = and block =
{ b_locals : var_dec list; { b_locals : var_dec list;
@ -107,21 +107,33 @@ type program =
p_consts : const_dec list; p_consts : const_dec list;
p_defs : class_def list } p_defs : class_def list }
let mk_var_dec ?(loc=no_location) name ty = let mk_var_dec ?(loc=no_location) ident ty =
{ v_ident = name; v_type = ty; v_loc = loc } { v_ident = ident; v_type = ty; v_loc = loc }
let mk_exp ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master : remove the invalid_type *) let mk_exp ?(loc=no_location) ty desc =
{ e_desc = desc; e_ty = ty; e_loc = loc } { e_desc = desc; e_ty = ty; e_loc = loc }
let mk_lhs ?(ty=invalid_type) ?(loc=no_location) desc = (* TODO master : remove the invalid_type *) let mk_exp_int ?(loc=no_location) desc =
{ e_desc = desc; e_ty = Initial.tint; e_loc = loc }
let mk_exp_bool ?(loc=no_location) desc =
{ e_desc = desc; e_ty = Initial.tbool; e_loc = loc }
let mk_pattern ?(loc=no_location) ty desc =
{ pat_desc = desc; pat_ty = ty; pat_loc = loc } { pat_desc = desc; pat_ty = ty; pat_loc = loc }
let mk_lhs_exp ?(ty=invalid_type) desc = (* TODO master : remove the invalid_type *) let mk_pattern_int ?(loc=no_location) desc =
let lhs = mk_lhs ~ty:ty desc in { pat_desc = desc; pat_ty = Initial.tint; pat_loc = loc }
mk_exp ~ty:ty (Elhs lhs)
let mk_pattern_exp ty desc =
let pat = mk_pattern ty desc in
mk_exp ty (Epattern pat)
let mk_evar ty id =
mk_exp ty (Epattern (mk_pattern ty (Lvar id)))
let mk_evar id = let mk_evar_int id =
mk_exp (Elhs (mk_lhs (Lvar id))) mk_exp Initial.tint (Epattern (mk_pattern Initial.tint (Lvar id)))
let mk_block ?(locals=[]) eq_list = let mk_block ?(locals=[]) eq_list =
{ b_locals = locals; { b_locals = locals;
@ -156,10 +168,10 @@ let vd_list_to_type vd_l = match vd_l with
let pattern_list_to_type p_l = match p_l with let pattern_list_to_type p_l = match p_l with
| [] -> Types.Tunit | [] -> Types.Tunit
| [p] -> p.pat_ty | [p] -> p.pat_ty
| _ -> Tprod (List.map (fun p -> p.p_type) p_l) | _ -> Tprod (List.map (fun p -> p.pat_ty) p_l)
let lhs_of_exp e = match e.e_desc with let pattern_of_exp e = match e.e_desc with
| Elhs l -> l | Epattern l -> l
| _ -> assert false | _ -> assert false
let find_step_method cd = let find_step_method cd =

4
compiler/obc/obc_mapfold.ml
Unescape Escape View File

@ -44,9 +44,9 @@ and edesc_it funs acc ed =
try funs.edesc funs acc ed try funs.edesc funs acc ed
with Fallback -> edesc funs acc ed with Fallback -> edesc funs acc ed
and edesc funs acc ed = match ed with and edesc funs acc ed = match ed with
| Elhs l -> | Epattern l ->
let l, acc = lhs_it funs acc l in let l, acc = lhs_it funs acc l in
Elhs l, acc Epattern l, acc
| Econst se -> | Econst se ->
let se, acc = static_exp_it funs.global_funs acc se in let se, acc = static_exp_it funs.global_funs acc se in
Econst se, acc Econst se, acc

6
compiler/obc/obc_printer.ml
Unescape Escape View File

@ -37,7 +37,7 @@ and print_exps ff e_list = print_list_r print_exp "" "," "" ff e_list
and print_exp ff e = and print_exp ff e =
match e.e_desc with match e.e_desc with
| Elhs lhs -> print_lhs ff lhs | Epattern lhs -> print_lhs ff lhs
| Econst c -> print_static_exp ff c | Econst c -> print_static_exp ff c
| Eop(op, e_list) -> print_op ff op e_list | Eop(op, e_list) -> print_op ff op e_list
| Estruct(_,f_e_list) -> | Estruct(_,f_e_list) ->
@ -90,8 +90,8 @@ let rec print_act ff a =
print_tag_act_list ff tag_act_list; print_tag_act_list ff tag_act_list;
fprintf ff "@]@,}@]" fprintf ff "@]@,}@]"
| Afor(x, i1, i2, act_list) -> | Afor(x, i1, i2, act_list) ->
fprintf ff "@[<v>@[<v 2>for %s = %a to %a {@ %a @]@,}@]" fprintf ff "@[<v>@[<v 2>for %a = %a to %a {@ %a @]@,}@]"
(name x) print_vd x
print_static_exp i1 print_static_exp i1
print_static_exp i2 print_static_exp i2
print_block act_list print_block act_list

11
compiler/utilities/misc.ml
Unescape Escape View File

@ -199,3 +199,14 @@ let split_string s separator = Str.split (separator |> Str.quote |> Str.regexp)
let file_extension s = split_string s "." |> last_element let file_extension s = split_string s "." |> last_element
exception Assert_false
let internal_error passe code =
Format.eprintf "@.---------\nInternal compiler error\nPasse : %s, Code : %d\n----------@." passe code;
raise Assert_false
exception Unsupported
let unsupported passe code =
Format.eprintf "@.---------\nUnsupported feature, please report it\nPasse : %s, Code : %d\n----------@." passe code;
raise Unsupported

6
compiler/utilities/misc.mli
Unescape Escape View File

@ -90,3 +90,9 @@ val (|>) : 'a -> ('a -> 'b) -> 'b
(** Return the extension of a filename string *) (** Return the extension of a filename string *)
val file_extension : string -> string val file_extension : string -> string
(** Internal error : Is used when an assertion wrong *)
val internal_error : string -> int -> 'a
(** Unsupported : Is used when something should work but is not currently supported *)
val unsupported : string -> int -> 'a

24
test/check
Unescape Escape View File

@ -114,18 +114,18 @@ launch_check () {
fi fi
fi fi
# Compil. java ? # Compil. java ?
if [[ ($echec == 0) && ($java == 1) ]]; then #if [[ ($echec == 0) && ($java == 1) ]]; then
pushd "${base_f}" > /dev/null # pushd "${base_f}_java" > /dev/null
for java_file in *.java ; do # for java_file in *.java ; do
if $JAVAC -warn:-unused -sourcepath .:..:../t1 ${java_file} > /dev/null # if $JAVAC -warn:-unused -sourcepath .:..:../t1 ${java_file} > /dev/null
then # then
echec=0 # echec=0
else # else
echec=3 # echec=3
fi # fi
done # done
popd > /dev/null # popd > /dev/null
fi #fi
# Compil. c ? # Compil. c ?
if [[ ($echec == 0) && ($c == 1) ]]; then if [[ ($echec == 0) && ($c == 1) ]]; then
pushd ${base_f}_c >/dev/null pushd ${base_f}_c >/dev/null

1
test/good/t5.ept
Unescape Escape View File

@ -1,6 +1,5 @@
(* pour debugger (* pour debugger
set arguments -v test/good/t1.mls *) set arguments -v test/good/t1.mls *)
type t
node f(x,z:int) returns (o1:int) node f(x,z:int) returns (o1:int)
var o: int; var o: int;

2
todo.txt
Unescape Escape View File

@ -1,6 +1,8 @@
Plus ou moins ordonné du plus urgent au moins urgent. Plus ou moins ordonné du plus urgent au moins urgent.
*- Bugs related to matching types without unaliasing it. In lots of parts. Use Modules.unalias_type.
*- Collision entre les noms de params et les idents dans les noeuds. *- Collision entre les noms de params et les idents dans les noeuds.
*- Optimisations du genre "if true then ... else ... " ou genre "x,y = if b then a,c else a2,c" qui devrait etre transformé en "x = if b then a else s2; y = c" ... *- Optimisations du genre "if true then ... else ... " ou genre "x,y = if b then a,c else a2,c" qui devrait etre transformé en "x = if b then a else s2; y = c" ...

Write Preview
Loading…
Cancel
Save