From 822e87605b7447ecfe2fb63ce7c7fcf1b8fed752 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Tue, 26 Apr 2011 18:36:00 +0200 Subject: [PATCH] One step closer to code generation with memalloc --- compiler/minils/analysis/interference.ml | 1 + compiler/obc/c/cgen.ml | 10 +++++++ compiler/obc/control.ml | 9 ------ compiler/obc/obc_utils.ml | 8 +++++ .../obc/transformations/memalloc_apply.ml | 30 +++++++++++-------- 5 files changed, 36 insertions(+), 22 deletions(-) diff --git a/compiler/minils/analysis/interference.ml b/compiler/minils/analysis/interference.ml index 691d5ff..febc347 100644 --- a/compiler/minils/analysis/interference.ml +++ b/compiler/minils/analysis/interference.ml @@ -240,6 +240,7 @@ let add_uses uses iv env = let ivars = all_ivars IvarSet.empty iv (World.ivar_type iv) in IvarSet.fold (fun iv env -> IvarEnv.add iv (number_uses iv uses) env) ivars env +(** TODO: compute correct live range for variables wit no use ?*) let compute_live_vars eqs = let uses = compute_uses eqs in print_debug_ivar_env "Uses" uses; diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index d7f6135..e1e4566 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -107,6 +107,7 @@ let rec ctype_of_otype oty = let cvarlist_of_ovarlist vl = let cvar_of_ovar vd = let ty = ctype_of_otype vd.v_type in + let ty = if Linearity.is_linear vd.v_linearity then pointer_to ty else ty in name vd.v_ident, ty in List.map cvar_of_ovar vl @@ -362,6 +363,15 @@ let out_var_name_of_objn o = of the called node, [mem] represents the node context and [args] the argument list.*) let step_fun_call var_env sig_info objn out args = + let rec add_targeting l ads = match l, ads with + | [], [] -> [] + | e::l, ad::ads -> + (*this arg is targeted, use a pointer*) + let e = if Linearity.is_linear ad.a_linearity then address_of e else e in + e::(add_targeting l ads) + | _, _ -> assert false + in + let args = (add_targeting args sig_info.node_inputs) in if sig_info.node_stateful then ( let mem = (match objn with diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml index 39eb6a1..712733a 100644 --- a/compiler/obc/control.ml +++ b/compiler/obc/control.ml @@ -45,15 +45,6 @@ let used_vars e = let _, vars = Obc_mapfold.exp_it funs [] e in vars - -let rec find_obj o j = match j with - | [] -> assert false - | obj::j -> - if o = obj.o_ident then - Modules.find_value obj.o_class - else - find_obj o j - let rec is_modified_by_call x args e_list = match args, e_list with | [], [] -> false | a::args, e::e_list -> diff --git a/compiler/obc/obc_utils.ml b/compiler/obc/obc_utils.ml index f5430f7..c333edb 100644 --- a/compiler/obc/obc_utils.ml +++ b/compiler/obc/obc_utils.ml @@ -101,6 +101,14 @@ let obj_ref_name o = | Oobj obj | Oarray (obj, _) -> obj +let rec find_obj o j = match j with + | [] -> assert false + | obj::j -> + if o = obj.o_ident then + Modules.find_value obj.o_class + else + find_obj o j + (** Input a block [b] and remove all calls to [Reset] method from it *) let remove_resets b = let block funs _ b = diff --git a/compiler/obc/transformations/memalloc_apply.ml b/compiler/obc/transformations/memalloc_apply.ml index f7dde8b..5b5dc69 100644 --- a/compiler/obc/transformations/memalloc_apply.ml +++ b/compiler/obc/transformations/memalloc_apply.ml @@ -1,5 +1,6 @@ open Types open Idents +open Signature open Linearity open Obc open Obc_utils @@ -83,24 +84,27 @@ let memalloc_subst_map inputs outputs mems subst_lists = 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 +let lhs funs (env, mut, j) l = match l.pat_desc with + | Lmem _ -> l, (env, mut, j) + | Larray _ -> Obc_mapfold.lhs funs (env, mut, j) l | Lvar _ | Lfield _ -> (* replace with representative *) let iv = ivar_of_pat l in try - { l with pat_desc = repr_from_ivar env iv }, (env, mut) + { l with pat_desc = repr_from_ivar env iv }, (env, mut, j) with - | Not_found -> l, (env, mut) + | Not_found -> l, (env, mut, j) -let act funs acc a = match a with - | Acall(_, _, Mstep, _) -> - let a, acc = Obc_mapfold.act funs acc a in - (* remove targeted outputs *) a, acc +let act funs (env,mut,j) a = match a with + | Acall(pat, o, Mstep, e_list) -> + let desc = Obc_utils.find_obj (obj_ref_name o) j in + let e_list = List.map (fun e -> fst (Obc_mapfold.exp_it funs (env,mut,j) e)) e_list in + let fix_pat p a l = if Linearity.is_linear a.a_linearity then l else p::l in + let pat = List.fold_right2 fix_pat pat desc.node_outputs [] in + Acall(pat, o, Mstep, e_list), (env,mut,j) | _ -> raise Errors.Fallback -let var_decs _ (env, mutables) vds = +let var_decs _ (env, mutables,j) vds = let var_dec vd acc = try if (var_name (IvarEnv.find (Ivar vd.v_ident) env)) <> vd.v_ident then @@ -113,7 +117,7 @@ let var_decs _ (env, mutables) vds = with | Not_found -> vd::acc in - List.fold_right var_dec vds [], (env, mutables) + List.fold_right var_dec vds [], (env, mutables,j) let add_other_vars md cd = @@ -141,11 +145,11 @@ let class_def funs acc cd = (*add linear variables not taken into account by memory allocation*) let mem_alloc = (add_other_vars md cd) @ cd.cd_mem_alloc in let env, mutables = memalloc_subst_map inputs outputs mems mem_alloc in - let cd, _ = Obc_mapfold.class_def funs (env, mutables) cd in + let cd, _ = Obc_mapfold.class_def funs (env, mutables, cd.cd_objs) 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 + let p, _ = Obc_mapfold.program_it funs (IvarEnv.empty, IdentSet.empty, []) p in p