From 2f346f873c4e3eca73acae23288d5f0fd6bb6570 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Thu, 14 Apr 2011 11:53:39 +0200 Subject: [PATCH] Control optimization as a pass on Obc There is now a obc_compiler.ml file, as in hept and minils. --- compiler/main/mls2obc.ml | 40 ++++++++++++++++++--------- compiler/{minils => }/main/mls2seq.ml | 8 ++---- compiler/obc/control.ml | 25 ++++++----------- compiler/obc/main/obc_compiler.ml | 19 +++++++++++++ 4 files changed, 57 insertions(+), 35 deletions(-) rename compiler/{minils => }/main/mls2seq.ml (94%) create mode 100644 compiler/obc/main/obc_compiler.ml diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 7fe8b19..7879143 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -19,6 +19,12 @@ open Types open Static open Initial +let var_from_name map x = + begin try + Env.find x map + with + _ -> assert false + end let fresh_it () = let id = Idents.gen_var "mls2obc" "i" in @@ -75,11 +81,19 @@ let rec bound_check_expr idx_list bounds = [e; bound_check_expr idx_list bounds])) | (_, _) -> internal_error "mls2obc" 3 +let rec control map ck s = + match ck with + | Cbase | Cvar { contents = Cindex _ } -> s + | Cvar { contents = Clink ck } -> control map ck s + | Con(ck, c, n) -> + let x = var_from_name map n in + control map ck (Acase(mk_exp x.pat_ty (Epattern x), [(c, mk_block [s])])) + let reinit o = Acall ([], o, Mreset, []) let rec translate_pat map = function - | Minils.Evarpat x -> [ Control.var_from_name map x ] + | Minils.Evarpat x -> [ var_from_name map x ] | Minils.Etuplepat pat_list -> List.fold_right (fun pat acc -> (translate_pat map pat) @ acc) pat_list [] @@ -93,7 +107,7 @@ let translate_var_dec l = let rec translate_extvalue map w = let desc = match w.w_desc with | Wconst v -> Econst v - | Wvar x -> Epattern (Control.var_from_name map n) + | Wvar x -> Epattern (var_from_name map n) | Wfield (w1, f) -> let w1 = translate_extvalue map (assert_1 e_list) in Epattern (mk_pattern e.e_ty (Lfield (pattern_of_exp e, f))) @@ -151,7 +165,7 @@ and translate_act map pat List.flatten (List.map2 (translate_act map) p_list const_list) (* When Merge *) | pat, Minils.Emerge (x, c_act_list) -> - let pattern = Control.var_from_name map x in + let pattern = var_from_name map x in [Acase (mk_exp pattern.pat_ty (Epattern pattern), translate_c_act_list map pat c_act_list)] (* Array ops *) @@ -159,7 +173,7 @@ and translate_act map pat Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) -> let cpt1, cpt1d = fresh_it () in let cpt2, cpt2d = fresh_it () in - let x = Control.var_from_name map x in + let x = var_from_name map x in let t = x.pat_ty in (match e1.Minils.e_ty, e2.Minils.e_ty with | Tarray (t1, n1), Tarray (t2, n2) -> @@ -183,7 +197,7 @@ and translate_act map pat Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = [n] }, [e], _) -> let cpt, cptd = fresh_it () in let e = translate_extvalue map e in - let x = Control.var_from_name map x in + let x = var_from_name map x in let t = match x.pat_ty with | Tarray (t,_) -> t | _ -> Misc.internal_error "mls2obc select slice type" 5 @@ -196,7 +210,7 @@ and translate_act map pat Minils.a_params = [idx1; idx2] }, [e], _) -> let cpt, cptd = fresh_it () in let e = translate_extvalue map e in - let x = Control.var_from_name map x in + let x = var_from_name map x in let t = match x.pat_ty with | Tarray (t,_) -> t | _ -> Misc.internal_error "mls2obc select slice type" 5 @@ -211,7 +225,7 @@ and translate_act map pat mk_pattern_exp t (Larray (pattern_of_exp e, 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 = var_from_name map x in let bounds = Mls_utils.bounds_list e1.Minils.e_ty in let e1 = translate_extvalue map e1 in let idx = List.map (translate_extvalue map) idx in @@ -222,7 +236,7 @@ and translate_act map pat [ Acase (cond, [ ptrue, mk_block [true_act]; pfalse, mk_block [false_act] ]) ] | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_trunc }, e1::idx, _) -> - let x = Control.var_from_name map x in + let x = var_from_name map x in let bounds = Mls_utils.bounds_list e1.Minils.e_ty in let e1 = translate_extvalue map e1 in let idx = List.map (translate_extvalue map) idx in @@ -230,7 +244,7 @@ and translate_act map pat [Aassgn (x, mk_exp p.pat_ty (Epattern p))] | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eupdate }, e1::e2::idx, _) -> - let x = Control.var_from_name map x in + let x = var_from_name map x in (** TODO: remplacer par if 0 < e && e < n then for () ; o[e] = v; for () else o = a *) let bounds = Mls_utils.bounds_list e1.Minils.e_ty in let idx = List.map (translate_extvalue map) idx in @@ -245,14 +259,14 @@ and translate_act map pat | Minils.Evarpat x, 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 = var_from_name map x in let copy = Aassgn (x, translate_extvalue map e1) in let action = Aassgn (mk_pattern x.pat_ty (Lfield (x, f)), translate_extvalue map e2) in (* TODO wrong type *) [copy; action] | Minils.Evarpat n, _ -> - [Aassgn (Control.var_from_name map n, translate map act)] + [Aassgn (var_from_name map n, translate map act)] | _ -> Format.eprintf "%a The pattern %a should be a simple var to be translated to obc.@." Location.print_location act.Minils.e_loc Mls_printer.print_pat pat; @@ -288,11 +302,11 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let { Minils.e_desc = desc; Minils.e_ck = ck; Minils.e_loc = loc } = e in match (pat, desc) with | Minils.Evarpat n, Minils.Efby (opt_c, e) -> - let x = Control.var_from_name map n in + let x = var_from_name map n in let si = (match opt_c with | None -> si | Some c -> (Aassgn (x, mk_exp x.pat_ty (Econst c))) :: si) in - let action = Aassgn (Control.var_from_name map n, translate_extvalue map e) in + let action = Aassgn (var_from_name map n, translate_extvalue map e) in v, si, j, (Control.control map ck action) :: s (* should be unnecessary | Minils.Etuplepat p_list, diff --git a/compiler/minils/main/mls2seq.ml b/compiler/main/mls2seq.ml similarity index 94% rename from compiler/minils/main/mls2seq.ml rename to compiler/main/mls2seq.ml index 5443fad..52e6a00 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/main/mls2seq.ml @@ -59,6 +59,7 @@ let generate_target p s = convert_fun p | Obc convert_fun -> let o = Mls2obc.program p in + let o = Obc_compiler.compile_program o in convert_fun o | Minils_no_params convert_fun -> let p_list = Callgraph.program p in @@ -66,11 +67,8 @@ let generate_target p s = | Obc_no_params convert_fun -> let p_list = Callgraph.program p in let o_list = List.map Mls2obc.program p_list in - print_unfolded p_list; - comment "Obc Callgraph"; - if !verbose then - List.iter (Obc_printer.print stdout) o_list; - List.iter convert_fun o_list + let o_list = List.map Obc_compiler.program o_list in + List.iter convert_fun o_list | Obc_scalar convert_fun -> let p = p |> Mls2obc.program |> Scalarize.program in convert_fun p diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml index 28319a6..9fe3dfc 100644 --- a/compiler/obc/control.ml +++ b/compiler/obc/control.ml @@ -9,20 +9,12 @@ (* control optimisation *) - -open Minils open Idents open Misc open Obc open Obc_utils open Clocks - -let var_from_name map x = - begin try - Env.find x map - with - _ -> assert false - end +open Obc_mapfold let fuse_blocks b1 b2 = { b1 with b_locals = b1.b_locals @ b2.b_locals; @@ -33,14 +25,6 @@ let rec find c = function | (c1, s1) :: h -> if c = c1 then s1, h else let s, h = find c h in s, (c1, s1) :: h -let rec control map ck s = - match ck with - | Cbase | Cvar { contents = Cindex _ } -> s - | Cvar { contents = Clink ck } -> control map ck s - | Con(ck, c, n) -> - let x = var_from_name map n in - control map ck (Acase(mk_exp x.pat_ty (Epattern x), [(c, mk_block [s])])) - let is_deadcode = function | Aassgn (lhs, e) -> (match e.e_desc with @@ -74,3 +58,10 @@ and joinhandlers h1 h2 = try let s2, h2'' = find c1 h2 in fuse_blocks s1 s2, h2'' with Not_found -> s1, h2 in (c1, join_block s1') :: joinhandlers h1' h2' + +let block funs acc b = + { b with b_body = joinlist b.b_body }, acc + +let program p = + let p, _ = program_it { defaults with block = block } () p in + p diff --git a/compiler/obc/main/obc_compiler.ml b/compiler/obc/main/obc_compiler.ml new file mode 100644 index 0000000..e6cfd92 --- /dev/null +++ b/compiler/obc/main/obc_compiler.ml @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Heptagon *) +(* *) +(* Author : Marc Pouzet *) +(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) +(* *) +(**************************************************************************) +open Misc +open Location +open Compiler_utils +open Compiler_options + +let pp p = if !verbose then Obc_printer.print stdout p + +let compile_program p = + (*Control optimization*) + let p = pass "Control optimization" true Control.program p pp in + p