From 3f9918b5708a6458e1b9b90c43fb715badae0c70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Wed, 20 Apr 2011 18:20:53 +0200 Subject: [PATCH] Added memory alloc application pass --- compiler/main/mls2obc.ml | 5 +- compiler/minils/analysis/interference.ml | 4 +- compiler/obc/main/obc_compiler.ml | 4 + compiler/obc/obc.ml | 3 +- .../obc/transformations/memalloc_apply.ml | 126 ++++++++++++++++++ 5 files changed, 138 insertions(+), 4 deletions(-) create mode 100644 compiler/obc/transformations/memalloc_apply.ml diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 007315b..b8d5f17 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -599,6 +599,7 @@ let translate_node ({ Minils.n_name = f; Minils.n_input = i_list; Minils.n_output = o_list; Minils.n_local = d_list; Minils.n_equs = eq_list; Minils.n_stateful = stateful; Minils.n_contract = contract; Minils.n_params = params; Minils.n_loc = loc; + Minils.n_mem_alloc = mem_alloc } as n) = Idents.enter_node f; let mem_var_tys = Mls_utils.node_memory_vars n in @@ -619,12 +620,12 @@ let translate_node let resetm = { m_name = Mreset; m_inputs = []; m_outputs = []; m_body = mk_block si } in if stateful then { cd_name = f; cd_stateful = true; cd_mems = m; cd_params = params; - cd_objs = j; cd_methods = [stepm; resetm]; cd_loc = loc; } + cd_objs = j; cd_methods = [stepm; resetm]; cd_loc = loc; cd_mem_alloc = mem_alloc } else ( (* Functions won't have [Mreset] or memories, they still have [params] and instances (of functions) *) { cd_name = f; cd_stateful = false; cd_mems = []; cd_params = params; - cd_objs = j; cd_methods = [stepm]; cd_loc = loc; } + cd_objs = j; cd_methods = [stepm]; cd_loc = loc; cd_mem_alloc = mem_alloc } ) let translate_ty_def { Minils.t_name = name; Minils.t_desc = tdesc; diff --git a/compiler/minils/analysis/interference.ml b/compiler/minils/analysis/interference.ml index 92145a1..5bddce8 100644 --- a/compiler/minils/analysis/interference.ml +++ b/compiler/minils/analysis/interference.ml @@ -98,7 +98,9 @@ module World = struct let vd = vd_from_ident x in vd.v_type | Ifield(_, f) -> - Tid (Modules.find_field f) + let n = Modules.find_field f in + let fields = Modules.find_struct n in + Signature.field_assoc f fields let is_optimized_ty ty = match Modules.unalias_type ty with diff --git a/compiler/obc/main/obc_compiler.ml b/compiler/obc/main/obc_compiler.ml index 686e3c7..333c3c0 100644 --- a/compiler/obc/main/obc_compiler.ml +++ b/compiler/obc/main/obc_compiler.ml @@ -16,4 +16,8 @@ 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 + + (* Memory allocation application *) + let p = pass "Application of Memory Allocation" !do_mem_alloc Memalloc_apply.program p pp in + p diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index d532dd0..24ebcf8 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -106,7 +106,8 @@ type class_def = cd_objs : obj_dec list; cd_params : param list; cd_methods: method_def list; - cd_loc : location } + cd_loc : location; + cd_mem_alloc : (ty * Interference_graph.ivar list) list; } type program = diff --git a/compiler/obc/transformations/memalloc_apply.ml b/compiler/obc/transformations/memalloc_apply.ml new file mode 100644 index 0000000..c3b9d0e --- /dev/null +++ b/compiler/obc/transformations/memalloc_apply.ml @@ -0,0 +1,126 @@ +open Types +open Idents +open Obc +open Obc_utils +open Obc_mapfold +open Interference_graph + +let rec ivar_of_pat l = match l.pat_desc with + | Lvar x -> Ivar x + | Lfield(l, f) -> Ifield (ivar_of_pat l, f) + | _ -> assert false + +let rec repr_from_ivar env iv = + try + let lhs = IvarEnv.find iv env in lhs.pat_desc + with + | Not_found -> + (match iv with + | Ivar x -> Lvar x + | Ifield(iv, f) -> + let ty = Tid (Modules.find_field f) in + let lhs = mk_pattern ty (repr_from_ivar env iv) in + Lfield (lhs, f) ) + +let rec choose_record_field env l = match l with + | [iv] -> repr_from_ivar env iv + | (Ivar _)::l -> choose_record_field env l + | (Ifield(iv,f))::_ -> repr_from_ivar env (Ifield(iv,f)) + | [] -> assert false + +(** Chooses from a list of vars (with the same color in the interference graph) + the one that will be used to store every other. It can be either an input, + an output or any var if there is no input or output in the list. *) +let choose_representative m inputs outputs mems ty vars = + let filter_ivs vars l = List.filter (fun iv -> List.mem iv l) vars in + let inputs = filter_ivs vars inputs in + let outputs = filter_ivs vars outputs in + let mems = filter_ivs vars mems in + let desc = match inputs, outputs, mems with + | [], [], [] -> choose_record_field m vars + | [], [], (Ivar m)::_ -> Lmem m + | [Ivar vin], [], [] -> Lvar vin + | [], [Ivar vout], [] -> Lvar vout + | [Ivar vin], [Ivar _], [] -> Lvar vin + | _, _, _ -> + (* Format.printf "Something is wrong with the coloring : "; + List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) vars; + Format.printf "\n Inputs : "; + List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) inputs; + Format.printf "\n Outputs : "; + List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) outputs; + Format.printf "\n Mem : "; + List.iter (fun vd -> Format.printf "%s," (ivar_to_string vd)) mems; + Format.printf "\n"; *) + assert false (*something went wrong in the coloring*) + in + mk_pattern ty desc + +let memalloc_subst_map inputs outputs mems subst_lists = + let map_from_subst_lists (env, mutables) l = + let add_to_map (env, mutables) (ty, l) = + let repr = choose_representative env inputs outputs mems ty l in + let env = List.fold_left (fun env iv -> IvarEnv.add iv repr env) env l in + let mutables = + if (List.length l > 2) || (List.mem (Ivar (var_name repr)) mems) then + IdentSet.add (var_name repr) mutables + else + mutables + in + env, mutables + in + List.fold_left add_to_map (env, mutables) l + in + let record_lists, other_lists = List.partition + (fun (ty,_) -> Interference.is_record_type ty) subst_lists in + let env, mutables = map_from_subst_lists (IvarEnv.empty, IdentSet.empty) record_lists in + map_from_subst_lists (env, mutables) other_lists + + +let lhs funs (env, mut) l = match l.pat_desc with + | Lmem _ -> l, (env, mut) + | Larray _ -> Obc_mapfold.lhs funs (env, mut) l + | Lvar _ | Lfield _ -> + (* replace with representative *) + let iv = ivar_of_pat l in + try + IvarEnv.find iv env, (env, mut) + with + | Not_found -> l, (env, mut) + +let act _ acc a = match a with + | Acall(_, _, Mstep, _) -> + (* remove targeted outputs *) a, acc + | _ -> raise Errors.Fallback + +let var_decs _ (env, mutables) vds = + let var_dec vd acc = + try + if (var_name (IvarEnv.find (Ivar vd.v_ident) env)) <> vd.v_ident then + (* remove unnecessary outputs *) + acc + else ( + let vd = if IdentSet.mem vd.v_ident mutables then { vd with v_mutable = true } else vd in + vd::acc + ) + with + | Not_found -> vd::acc + in + List.fold_right var_dec vds [], (env, mutables) + +let class_def funs acc cd = + (* find the substitution and apply it to the body of the class *) + let ivars_of_vds vds = List.map (fun vd -> Ivar vd.v_ident) vds in + let md = find_step_method cd in + let inputs = ivars_of_vds md.m_inputs in + let outputs = ivars_of_vds md.m_outputs in + let mems = ivars_of_vds cd.cd_mems in + let env, mutables = memalloc_subst_map inputs outputs mems cd.cd_mem_alloc in + let cd, _ = Obc_mapfold.class_def funs (env, mutables) cd in + cd, acc + +let program p = + let funs = { Obc_mapfold.defaults with class_def = class_def; var_decs = var_decs; + act = act; lhs = lhs } in + let p, _ = Obc_mapfold.program_it funs (IvarEnv.empty, IdentSet.empty) p in + p