From 5d2f7dfa85600b6fbb19fc88c826b814b3706ff8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Thu, 14 Apr 2011 18:06:54 +0200 Subject: [PATCH] jeudi soir. still on mls2obc. --- compiler/global/clocks.ml | 7 +- compiler/global/global_mapfold.ml | 5 +- compiler/global/global_printer.ml | 5 +- compiler/global/initial.ml | 6 +- compiler/global/modules.ml | 3 +- compiler/heptagon/analysis/typing.ml | 5 +- compiler/heptagon/parsing/hept_scoping.ml | 2 +- compiler/heptagon/transformations/automata.ml | 2 +- compiler/main/mls2obc.ml | 60 +++++------ compiler/main/mls2seq.ml | 4 +- compiler/minils/minils.ml | 7 +- compiler/minils/mls_mapfold.ml | 101 +++++++++++------- compiler/minils/mls_printer.ml | 84 ++++++++------- compiler/minils/mls_utils.ml | 8 +- compiler/obc/c/cgen.ml | 3 +- compiler/obc/c/cmain.ml | 4 +- compiler/obc/java/java.ml | 2 - compiler/obc/java/java_printer.ml | 1 - compiler/obc/java/obc2java.ml | 8 +- compiler/obc/main/obc_compiler.ml | 4 +- compiler/obc/obc_utils.ml | 6 +- compiler/obc/transformations/scalarize.ml | 2 +- 22 files changed, 170 insertions(+), 159 deletions(-) diff --git a/compiler/global/clocks.ml b/compiler/global/clocks.ml index 5028474..2b65c1d 100644 --- a/compiler/global/clocks.ml +++ b/compiler/global/clocks.ml @@ -90,13 +90,10 @@ and unify_list t1_list t2_list = let rec skeleton ck = function | Tprod ty_list -> (match ty_list with - | [] -> - Format.eprintf "Internal error, an exp with invalid type@."; - assert false; + | [] -> Ck ck | _ -> Cprod (List.map (skeleton ck) ty_list)) | Tarray (t, _) -> skeleton ck t - | Tmutable t -> skeleton ck t - | Tid _ | Tunit -> Ck ck + | Tid _ | Tinvalid -> Ck ck (* TODO here it implicitely says that the base clock is Cbase and that all tuple is on Cbase *) diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index facb84a..c96f595 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -57,10 +57,7 @@ and ty funs acc t = match t with let t, acc = ty_it funs acc t in let se, acc = static_exp_it funs acc se in Tarray (t, se), acc - | Tmutable t -> - let t, acc = ty_it funs acc t in - Tmutable t, acc - | Tunit -> t, acc + | Tinvalid -> t, acc (* and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc t and ct funs acc c = match c with diff --git a/compiler/global/global_printer.ml b/compiler/global/global_printer.ml index 9306ae4..579cb99 100644 --- a/compiler/global/global_printer.ml +++ b/compiler/global/global_printer.ml @@ -64,15 +64,12 @@ and print_static_exp_tuple ff l = fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l and print_type ff = function - | Tprod [] -> fprintf ff "INVALID TYPE" + | Tinvalid -> fprintf ff "INVALID TYPE" | Tprod ty_list -> fprintf ff "@[%a@]" (print_list_r print_type "(" " *" ")") ty_list | Tid id -> print_qualname ff id | Tarray (ty, n) -> fprintf ff "@[%a^%a@]" print_type ty print_static_exp n - | Tmutable ty -> - fprintf ff "@[mutable %a@]" print_type ty - | Tunit -> fprintf ff "unit" let print_field ff field = fprintf ff "@[%a: %a@]" print_qualname field.f_name print_type field.f_type diff --git a/compiler/global/initial.ml b/compiler/global/initial.ml index 11244ad..99e2b4e 100644 --- a/compiler/global/initial.ml +++ b/compiler/global/initial.ml @@ -28,13 +28,13 @@ let tfloat = Types.Tid pfloat let mk_pervasives s = { qual = Pervasives; name = s } let mk_static_int_op op args = - mk_static_exp ~ty:tint (Sop (op,args)) + mk_static_exp tint (Sop (op,args)) let mk_static_int i = - mk_static_exp ~ty:tint (Sint i) + mk_static_exp tint (Sint i) let mk_static_bool b = - mk_static_exp ~ty:tbool (Sbool b) + mk_static_exp tbool (Sbool b) diff --git a/compiler/global/modules.ml b/compiler/global/modules.ml index 6273f84..7a72408 100644 --- a/compiler/global/modules.ml +++ b/compiler/global/modules.ml @@ -291,8 +291,7 @@ let rec unalias_type t = match t with with Not_found -> raise (Undefined_type ty_name)) | Tarray (ty, n) -> Tarray(unalias_type ty, n) | Tprod ty_list -> Tprod (List.map unalias_type ty_list) - | Tmutable t -> Tmutable (unalias_type t) - | Tunit -> Tunit + | Tinvalid -> Tinvalid (** Return the current module as a [module_object] *) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 3fd18bb..6ae3449 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -257,7 +257,6 @@ let build_subst names values = let rec subst_type_vars m = function | Tarray(ty, e) -> Tarray(subst_type_vars m ty, simplify m e) | Tprod l -> Tprod (List.map (subst_type_vars m) l) - | Tmutable t -> Tmutable (subst_type_vars m t) | t -> t let add_distinct_env id ty env = @@ -392,9 +391,7 @@ let rec check_type const_env = function | Tid ty_name -> Tid ty_name (* TODO bug ? should check that ty_name exists ? *) | Tprod l -> Tprod (List.map (check_type const_env) l) - | Tmutable t -> - Tmutable (check_type const_env t) - | Tunit -> Tunit + | Tinvalid -> Tinvalid and typing_static_exp const_env se = try diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index ec6a780..bda7df3 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -181,7 +181,7 @@ let static_app_from_app app args= let rec translate_static_exp se = try let se_d = translate_static_exp_desc se.se_desc in - Types.mk_static_exp ~loc:se.se_loc se_d + Types.mk_static_exp Tinvalid ~loc:se.se_loc se_d with | ScopingError err -> message se.se_loc err diff --git a/compiler/heptagon/transformations/automata.ml b/compiler/heptagon/transformations/automata.ml index dd192fe..28f0412 100644 --- a/compiler/heptagon/transformations/automata.ml +++ b/compiler/heptagon/transformations/automata.ml @@ -40,7 +40,7 @@ let mk_exp_fby_false e = (Tid Initial.pbool) let mk_constructor constr ty = - mk_static_exp ~ty:ty (Sconstructor constr) + mk_static_exp ty (Sconstructor constr) (* Be sure that [initial] is of the right type [e.e_ty] before using this *) let mk_exp_fby_state initial e = diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index e4f7d6e..1e3ed4f 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -11,6 +11,7 @@ open Misc open Names open Idents +open Clocks open Signature open Obc open Obc_utils @@ -32,7 +33,7 @@ let fresh_it () = let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst") let fresh_for = fresh_for "mls2obc" -let copy_array = copy_array "mls2obc" +(*let copy_array = copy_array "mls2obc"*) let op_from_string op = { qual = Pervasives; name = op; } @@ -72,7 +73,7 @@ let rec bound_check_expr idx_list bounds = let e1 = mk_exp_bool (Eop (op_from_string "<", [idx; mk_exp_int (Econst n)])) in let e2 = mk_exp_bool (Eop (op_from_string "<=", - [mk_exp_int (Econst (Sint 0)); idx])) in + [mk_exp_int (Econst (mk_static_int 0)); idx])) in mk_exp_bool (Eop (op_from_string "&", [e1;e2])) in match (idx_list, bounds) with @@ -85,28 +86,24 @@ let rec bound_check_expr idx_list bounds = (** Creates the action list that copies [src] to [dest], updating the value at index [idx_list] with the value [v]. *) -let rec update_array dest src idx_list v = match dest.l_ty, idx_list with +let rec update_array dest src idx_list v = match dest.pat_ty, idx_list with | Tarray (t, n), idx::idx_list -> (*Body of the copy loops*) let copy i = let src_i = mk_pattern_exp t (Larray (src, i)) in let dest_i = mk_pattern t (Larray (dest, i)) in - [Aassgn(dest_i, src_i)] + [Aassgn(dest_i, src_i)] in - (*Copy values < idx*) let a_lower = fresh_for (mk_static_int 0) idx copy in - (* Update the correct element*) - let src_idx = mk_pattern_exp t (Larray (src, idx)) in - let dest_idx = mk_pattern t (Larray (dest, idx)) in - let a_update = update_array dest_idx src_idx v idx_list in - + let src_idx = mk_pattern t (Larray (src, mk_exp_int (Econst idx))) in + let dest_idx = mk_pattern t (Larray (dest, mk_exp_int (Econst idx))) in + let a_update = update_array dest_idx src_idx idx_list v in (*Copy values > idx*) let idx_plus_one = mk_static_int_op (mk_pervasives "+") [idx; mk_static_int 1] in let a_upper = fresh_for idx_plus_one n copy in - [a_lower] @ a_update @ [a_upper] - + [a_lower] @ a_update @ [a_upper] | _, _ -> [Aassgn(dest, v)] @@ -121,9 +118,11 @@ let update_record dest src f v = else Aassgn(dest_l, src_l) in - let n = struct_name dest.l_ty in - let fields = find_struct n in - List.map assgn_act fields + let fields = match dest.pat_ty with + | Tid n -> Modules.find_struct n + | _ -> Misc.internal_error "mls2obc field of nonstruct" 1 + in + List.map assgn_act fields let rec control map ck s = match ck with @@ -149,23 +148,23 @@ let translate_var_dec l = List.map one_var l let rec translate_extvalue map w = - let desc = match w.w_desc with - | Wconst v -> Econst v - | 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))) - | Wwhen (w1, c, x) -> - let e1 = translate_extvalue map w1 in + let desc = match w.Minils.w_desc with + | Minils.Wconst v -> Econst v + | Minils.Wvar x -> Epattern (var_from_name map x) + | Minils.Wfield (w1, f) -> + let e = translate_extvalue map w1 in + Epattern (mk_pattern w.Minils.w_ty (Lfield (pattern_of_exp e, f))) + | Minils.Wwhen (w1, c, x) -> + let e1 = translate_extvalue map w1 in e1.e_desc in - mk_exp e.Minils.e_ty desc + mk_exp w.Minils.w_ty desc (* [translate e = c] *) let rec translate map e = let desc = match e.Minils.e_desc with | Minils.Eextvalue w -> - let e = translate_ext_value map e in e.e_desc + let e = translate_extvalue map w in e.e_desc | Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) -> Eop (op_from_string "=", List.map (translate_extvalue map ) e_list) | Minils.Eapp ({ Minils.a_op = Minils.Efun n }, e_list, _) @@ -189,10 +188,10 @@ let rec translate map e = (* Already treated cases when translating the [eq] *) | Minils.Eiterator _ | Minils.Emerge _ | Minils.Efby _ | Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat - |Minils.Eupdate|Minils.Eselect_dyn - |Minils.Eselect_trunc|Minils.Eselect_slice - |Minils.Earray_fill|Minils.Efield_update - |Minils.Eifthenelse|Minils.Etuple)}, _, _) -> + |Minils.Eupdate|Minils.Eselect_dyn + |Minils.Eselect_trunc|Minils.Eselect_slice + |Minils.Earray_fill|Minils.Efield_update + |Minils.Eifthenelse|Minils.Etuple)}, _, _) -> internal_error "mls2obc" 5 in mk_exp e.Minils.e_ty desc @@ -204,7 +203,8 @@ and translate_act map pat | Minils.Etuplepat p_list, Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) -> List.flatten (List.map2 (translate_act map) p_list act_list) - | Minils.Etuplepat p_list, Minils.Econst { se_desc = Stuple se_list } -> + | Minils.Etuplepat p_list, + Minils.Eextvalue { Minils.w_desc = Minils.Wconst { se_desc = Stuple se_list }} -> let const_list = Mls_utils.exp_list_of_static_exp_list se_list in List.flatten (List.map2 (translate_act map) p_list const_list) (* When Merge *) diff --git a/compiler/main/mls2seq.ml b/compiler/main/mls2seq.ml index e4ad7d4..041dbaf 100644 --- a/compiler/main/mls2seq.ml +++ b/compiler/main/mls2seq.ml @@ -41,8 +41,8 @@ let write_obc_file p = let no_conf () = () let targets = [ "c",(Obc_no_params Cmain.program, no_conf); - "java", (Obc_scalar Java_main.program, java_conf); - "obc", (Obc write_obc_file, no_conf; + "java", (Obc Java_main.program, java_conf); + "obc", (Obc write_obc_file, no_conf); "obc_np", (Obc_no_params write_obc_file, no_conf); "epo", (Minils write_object_file, no_conf) ] diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 4f7f012..e24fe85 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -40,7 +40,7 @@ and tdesc = | Type_struct of structure and extvalue = { - w_desc : edesc; + w_desc : extvalue_desc; mutable w_ck: ck; w_ty : ty; w_loc : location } @@ -82,7 +82,6 @@ and op = | Efun of fun_name (** "Stateless" longname <> (args) reset r *) | Enode of fun_name (** "Stateful" longname <> (args) reset r *) | Eifthenelse (** if arg1 then arg2 else arg3 *) - | Efield (** arg1.a_param1 *) | Efield_update (** { arg1 with a_param1 = arg2 } *) | Earray (** [ args ] *) | Earray_fill (** [arg1^a_param1] *) @@ -150,7 +149,7 @@ let mk_extvalue ~ty ?(clock = fresh_clock()) ?(loc = no_location) desc = { w_desc = desc; w_ty = ty; w_ck = clock; w_loc = loc } -let mk_exp ~ty ?(clock = fresh_clock()) ?(loc = no_location) desc = +let mk_exp ty ?(clock = fresh_clock()) ?(loc = no_location) desc = { e_desc = desc; e_ty = ty; e_ck = clock; e_loc = loc } @@ -189,4 +188,4 @@ let mk_program o n t c = { p_modname = Module ""; p_format_version = ""; p_opened = o; p_nodes = n; p_types = t; p_consts = c } -let void = mk_exp ~ty:Types.Tunit (Eapp (mk_app Etuple, [], None)) +let void = mk_exp (Types.Tprod []) (Eapp (mk_app Etuple, [], None)) diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index d5e7aa2..d3719df 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -17,22 +17,23 @@ open Minils either yours either the default version named according to the type. *) type 'a mls_it_funs = { - app: 'a mls_it_funs -> 'a -> Minils.app -> Minils.app * 'a; - edesc: 'a mls_it_funs -> 'a -> Minils.edesc -> Minils.edesc * 'a; - eq: 'a mls_it_funs -> 'a -> Minils.eq -> Minils.eq * 'a; - eqs: 'a mls_it_funs -> 'a -> Minils.eq list -> Minils.eq list * 'a; - exp: 'a mls_it_funs -> 'a -> Minils.exp -> Minils.exp * 'a; - pat: 'a mls_it_funs -> 'a -> Minils.pat -> Minils.pat * 'a; - var_dec: 'a mls_it_funs -> 'a -> Minils.var_dec -> Minils.var_dec * 'a; - var_decs: 'a mls_it_funs -> 'a -> Minils.var_dec list - -> Minils.var_dec list * 'a; - contract: 'a mls_it_funs -> 'a -> Minils.contract -> Minils.contract * 'a; - node_dec: 'a mls_it_funs -> 'a -> Minils.node_dec -> Minils.node_dec * 'a; - const_dec: 'a mls_it_funs -> 'a -> Minils.const_dec -> Minils.const_dec * 'a; - type_dec: 'a mls_it_funs -> 'a -> Minils.type_dec -> Minils.type_dec * 'a; - tdesc: 'a mls_it_funs -> 'a -> Minils.tdesc -> Minils.tdesc * 'a; - program: 'a mls_it_funs -> 'a -> Minils.program -> Minils.program * 'a; - global_funs:'a Global_mapfold.global_it_funs } + app: 'a mls_it_funs -> 'a -> Minils.app -> Minils.app * 'a; + edesc: 'a mls_it_funs -> 'a -> Minils.edesc -> Minils.edesc * 'a; + eq: 'a mls_it_funs -> 'a -> Minils.eq -> Minils.eq * 'a; + eqs: 'a mls_it_funs -> 'a -> Minils.eq list -> Minils.eq list * 'a; + exp: 'a mls_it_funs -> 'a -> Minils.exp -> Minils.exp * 'a; + extvalue: 'a mls_it_funs -> 'a -> Minils.extvalue -> Minils.extvalue * 'a; + extvalue_desc: 'a mls_it_funs -> 'a -> Minils.extvalue_desc -> Minils.extvalue_desc * 'a; + pat: 'a mls_it_funs -> 'a -> Minils.pat -> Minils.pat * 'a; + var_dec: 'a mls_it_funs -> 'a -> Minils.var_dec -> Minils.var_dec * 'a; + var_decs: 'a mls_it_funs -> 'a -> Minils.var_dec list -> Minils.var_dec list * 'a; + contract: 'a mls_it_funs -> 'a -> Minils.contract -> Minils.contract * 'a; + node_dec: 'a mls_it_funs -> 'a -> Minils.node_dec -> Minils.node_dec * 'a; + const_dec: 'a mls_it_funs -> 'a -> Minils.const_dec -> Minils.const_dec * 'a; + type_dec: 'a mls_it_funs -> 'a -> Minils.type_dec -> Minils.type_dec * 'a; + tdesc: 'a mls_it_funs -> 'a -> Minils.tdesc -> Minils.tdesc * 'a; + program: 'a mls_it_funs -> 'a -> Minils.program -> Minils.program * 'a; + global_funs: 'a Global_mapfold.global_it_funs } let rec exp_it funs acc e = funs.exp funs acc e @@ -41,43 +42,59 @@ and exp funs acc e = let ed, acc = edesc_it funs acc e.e_desc in { e with e_desc = ed; e_ty = e_ty }, acc +and extvalue_it funs acc w = funs.extvalue funs acc w +and extvalue funs acc w = + let w_ty, acc = ty_it funs.global_funs acc w.w_ty in + let wd, acc = extvalue_desc_it funs acc w.w_desc in + { w with w_desc = wd; w_ty = w_ty }, acc + +and extvalue_desc_it funs acc wd = + try funs.extvalue_desc funs acc wd + with Fallback -> extvalue_desc funs acc wd +and extvalue_desc funs acc wd = match wd with + | Wconst se -> + let se, acc = static_exp_it funs.global_funs acc se in + Wconst se, acc + | Wvar _ -> wd, acc + | Wfield (w,f) -> + let w, acc = extvalue_it funs acc w in + Wfield (w,f), acc + | Wwhen (w, c, v) -> + let w, acc = extvalue_it funs acc w in + Wwhen (w,c,v), acc and edesc_it funs acc ed = try funs.edesc funs acc ed with Fallback -> edesc funs acc ed and edesc funs acc ed = match ed with - | Econst se -> - let se, acc = static_exp_it funs.global_funs acc se in - Econst se, acc - | Evar _ -> ed, acc - | Efby (se, e) -> + | Eextvalue w -> + let w, acc = extvalue_it funs acc w in + Eextvalue w, acc + | Efby (se, w) -> let se, acc = optional_wacc (static_exp_it funs.global_funs) acc se in - let e, acc = exp_it funs acc e in - Efby (se, e), acc + let w, acc = extvalue_it funs acc w in + Efby (se, w), acc | Eapp(app, args, reset) -> let app, acc = app_it funs acc app in - let args, acc = mapfold (exp_it funs) acc args in + let args, acc = mapfold (extvalue_it funs) acc args in Eapp (app, args, reset), acc - | Ewhen(e, c, x) -> - let e, acc = exp_it funs acc e in - Ewhen(e, c, x), acc - | Emerge(x, c_e_list) -> - let aux acc (c,e) = - let e, acc = exp_it funs acc e in - (c,e), acc in - let c_e_list, acc = mapfold aux acc c_e_list in - Emerge(x, c_e_list), acc - | Estruct n_e_list -> - let aux acc (n,e) = - let e, acc = exp_it funs acc e in - (n,e), acc in - let n_e_list, acc = mapfold aux acc n_e_list in - Estruct n_e_list, acc + | Emerge(x, c_w_list) -> + let aux acc (c,w) = + let w, acc = extvalue_it funs acc w in + (c,w), acc in + let c_w_list, acc = mapfold aux acc c_w_list in + Emerge(x, c_w_list), acc + | Estruct n_w_list -> + let aux acc (n,w) = + let w, acc = extvalue_it funs acc w in + (n,w), acc in + let n_w_list, acc = mapfold aux acc n_w_list in + Estruct n_w_list, acc | Eiterator (i, app, param, pargs, args, reset) -> let app, acc = app_it funs acc app in let param, acc = static_exp_it funs.global_funs acc param in - let pargs, acc = mapfold (exp_it funs) acc pargs in - let args, acc = mapfold (exp_it funs) acc args in + let pargs, acc = mapfold (extvalue_it funs) acc pargs in + let args, acc = mapfold (extvalue_it funs) acc args in Eiterator (i, app, param, pargs, args, reset), acc @@ -183,6 +200,8 @@ let defaults = { eq = eq; eqs = eqs; exp = exp; + extvalue = extvalue; + extvalue_desc = extvalue_desc; pat = pat; var_dec = var_dec; var_decs = var_decs; diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index e318861..7b610c5 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -68,6 +68,9 @@ and print_node_params ff l = and print_exp_tuple ff l = fprintf ff "@[<2>(%a)@]" (print_list_r print_exp """,""") l +and print_w_tuple ff l = + fprintf ff "@[<2>(%a)@]" (print_list_r print_extvalue """,""") l + and print_vd_tuple ff l = fprintf ff "@[<2>%a@]" (print_list_r print_vd "("";"")") l @@ -75,10 +78,10 @@ and print_index ff idx = fprintf ff "@[<2>%a@]" (print_list print_static_exp "[""][""]") idx and print_dyn_index ff idx = - fprintf ff "@[<2>%a@]" (print_list print_exp "[""][""]") idx + fprintf ff "@[<2>%a@]" (print_list print_extvalue "[""][""]") idx and print_trunc_index ff idx = - fprintf ff "@[<2>%a@]" (print_list print_exp "[>""<][>""<]") idx + fprintf ff "@[<2>%a@]" (print_list print_extvalue "[>""<][>""<]") idx and print_exp ff e = if !Compiler_options.full_type_info then @@ -89,87 +92,90 @@ and print_exp ff e = and print_every ff reset = print_opt (fun ff id -> fprintf ff " every %a" print_ident id) ff reset +and print_extvalue ff w = + if !Compiler_options.full_type_info then + fprintf ff "(%a : %a :: %a)" + print_extvalue_desc w.w_desc print_type w.w_ty print_ck w.w_ck + else fprintf ff "%a" print_extvalue_desc w.w_desc + + +and print_extvalue_desc ff = function + | Wconst c -> print_static_exp ff c + | Wvar x -> print_ident ff x + | Wfield (w,f) -> fprintf ff "%a.%a" print_extvalue w print_qualname f + | Wwhen (w, c, n) -> + fprintf ff "@[<2>(%a@ when %a(%a))@]" print_extvalue w print_qualname c print_ident n + and print_exp_desc ff = function - | Econst c -> print_static_exp ff c - | Evar x -> print_ident ff x - | Efby ((Some c), e) -> - fprintf ff "@[<2>%a fby@ %a@]" print_static_exp c print_exp e - | Efby (None, e) -> fprintf ff "pre %a" print_exp e + | Eextvalue w -> print_extvalue ff w + | Efby ((Some c), w) -> fprintf ff "@[<2>%a fby@ %a@]" print_static_exp c print_extvalue w + | Efby (None, w) -> fprintf ff "pre %a" print_extvalue w | Eapp (app, args, reset) -> - fprintf ff "@[<2>%a@,%a@]" - print_app (app, args) print_every reset - | Ewhen (e, c, n) -> - fprintf ff "@[<2>(%a@ when %a(%a))@]" - print_exp e print_qualname c print_ident n - | Emerge (x, tag_e_list) -> - fprintf ff "@[<2>merge %a@ %a@]" - print_ident x print_tag_e_list tag_e_list - | Estruct f_e_list -> - print_record (print_couple print_qualname print_exp """ = """) ff f_e_list + fprintf ff "@[<2>%a@,%a@]" print_app (app, args) print_every reset + | Emerge (x, tag_w_list) -> + fprintf ff "@[<2>merge %a@ %a@]" print_ident x print_tag_w_list tag_w_list + | Estruct f_w_list -> + print_record (print_couple print_qualname print_extvalue """ = """) ff f_w_list | Eiterator (it, f, param, pargs, args, reset) -> fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a" (iterator_to_string it) print_app (f, []) print_static_exp param - print_exp_tuple pargs - print_exp_tuple args + print_w_tuple pargs + print_w_tuple args print_every reset and print_app ff (app, args) = match app.a_op with | Eequal -> let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a@ = %a@]" print_exp e1 print_exp e2 - | Etuple -> print_exp_tuple ff args + fprintf ff "@[<2>%a@ = %a@]" print_extvalue e1 print_extvalue e2 + | Etuple -> print_w_tuple ff args | Efun f | Enode f -> fprintf ff "@[%a@,%a@,%a@]" - print_qualname f print_params app.a_params print_exp_tuple args + print_qualname f print_params app.a_params print_w_tuple args | Eifthenelse -> let e1, e2, e3 = assert_3 args in fprintf ff "@[if %a@ then %a@ else %a@]" - print_exp e1 print_exp e2 print_exp e3 - | Efield -> - let r = assert_1 args in - let f = assert_1 app.a_params in - fprintf ff "%a.%a" print_exp r print_static_exp f + print_extvalue e1 print_extvalue e2 print_extvalue e3 | Efield_update -> let r,e = assert_2 args in let f = assert_1 app.a_params in fprintf ff "@[<2>{%a with .%a =@ %a}@]" - print_exp r print_static_exp f print_exp e - | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args + print_extvalue r print_static_exp f print_extvalue e + | Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_extvalue "["";""]") args | Earray_fill -> let e = assert_1 args in let n = assert_1 app.a_params in - fprintf ff "%a^%a" print_exp e print_static_exp n + fprintf ff "%a^%a" print_extvalue e print_static_exp n | Eselect -> let e = assert_1 args in - fprintf ff "%a%a" print_exp e print_index app.a_params + fprintf ff "%a%a" print_extvalue e print_index app.a_params | Eselect_slice -> let e = assert_1 args in let idx1, idx2 = assert_2 app.a_params in fprintf ff "%a[%a..%a]" - print_exp e print_static_exp idx1 print_static_exp idx2 + print_extvalue e print_static_exp idx1 print_static_exp idx2 | Eselect_dyn -> let r, d, e = assert_2min args in fprintf ff "%a%a default %a" - print_exp r print_dyn_index e print_exp d + print_extvalue r print_dyn_index e print_extvalue d | Eselect_trunc -> let e, idx_list = assert_1min args in - fprintf ff "%a%a" print_exp e print_trunc_index idx_list + fprintf ff "%a%a" print_extvalue e print_trunc_index idx_list | Eupdate -> let e1, e2, idx = assert_2min args in fprintf ff "@[<2>(%a with %a =@ %a)@]" - print_exp e1 print_dyn_index idx print_exp e2 + print_extvalue e1 print_dyn_index idx print_extvalue e2 | Econcat -> let e1, e2 = assert_2 args in - fprintf ff "@[<2>%a@ @@ %a@]" print_exp e1 print_exp e2 + fprintf ff "@[<2>%a@ @@ %a@]" print_extvalue e1 print_extvalue e2 and print_handler ff c = - fprintf ff "@[<2>%a@]" (print_couple print_qualname print_exp "("" -> "")") c + fprintf ff "@[<2>%a@]" (print_couple print_qualname print_extvalue "("" -> "")") c -and print_tag_e_list ff tag_e_list = - fprintf ff "@[%a@]" (print_list print_handler """""") tag_e_list +and print_tag_w_list ff tag_w_list = + fprintf ff "@[%a@]" (print_list print_handler """""") tag_w_list and print_eq ff { eq_lhs = p; eq_rhs = e } = diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index 962bcee..facf789 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -22,7 +22,9 @@ let err_message ?(exp=void) ?(loc=exp.e_loc) = function let rec static_exp_of_exp e = match e.e_desc with - | Econst se -> se + | Eextvalue w -> (match w.w_desc with + | Wconst se -> se + | _ -> err_message ~exp:e Enot_static_exp) | _ -> err_message ~exp:e Enot_static_exp (** @return the list of bounds of an array type*) @@ -54,7 +56,7 @@ let is_record_type ty = match ty with let is_op = function | { qual = Pervasives; name = _ } -> true | _ -> false - +(* module Vars = struct let add x acc = if List.mem x acc then acc else x :: acc @@ -71,6 +73,7 @@ struct let read_exp read_funs (is_left, acc_init) e = (* recursive call *) let _,(_, acc) = Mls_mapfold.exp read_funs (is_left, acc_init) e in + (* special cases *) let acc = match e.e_desc with | Evar x | Emerge(x,_) | Ewhen(_, _, x) @@ -163,3 +166,4 @@ module AllDep = Dep.Make end) let eq_find id = List.find (fun eq -> List.mem id (Vars.def [] eq)) +*) \ No newline at end of file diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 8870142..fc4988d 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -101,9 +101,8 @@ let rec ctype_of_otype oty = | Types.Tid id when id = Initial.pbool -> Cty_int | Tid id -> Cty_id id | Tarray(ty, n) -> Cty_arr(int_of_static_exp n, ctype_of_otype ty) - | Tmutable t -> ctype_of_otype t | Tprod _ -> assert false - | Tunit -> assert false + | Tinvalid -> assert false let cvarlist_of_ovarlist vl = let cvar_of_ovar vd = diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index e386f92..d3a4f0b 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -88,7 +88,7 @@ let assert_node_res cd = statements) needed for a main() function calling [cd]. *) let main_def_of_class_def cd = let format_for_type ty = match ty with - | Tarray _ | Tprod _ | Tmutable _ | Tunit -> assert false + | Tarray _ | Tprod _ | Tinvalid -> assert false | Types.Tid id when id = Initial.pfloat -> "%f" | Types.Tid id when id = Initial.pint -> "%d" | Types.Tid id when id = Initial.pbool -> "%d" @@ -98,7 +98,7 @@ let main_def_of_class_def cd = (** Does reading type [ty] need a buffer? When it is the case, [need_buf_for_ty] also returns the type's name. *) let need_buf_for_ty ty = match ty with - | Tarray _ | Tprod _ | Tmutable _ | Tunit -> assert false + | Tarray _ | Tprod _ | Tinvalid -> assert false | Types.Tid id when id = Initial.pfloat -> None | Types.Tid id when id = Initial.pint -> None | Types.Tid id when id = Initial.pbool -> None diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index f2b5d2b..93e42b5 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -23,7 +23,6 @@ type ty = Tclass of class_name | Tint | Tfloat | Tarray of ty * exp - | Tref of ty | Tunit and classe = { c_protection : protection; @@ -108,7 +107,6 @@ let rec default_value ty = match ty with | Tint -> Sint 0 | Tfloat -> Sfloat 0.0 | Tunit -> Evoid - | Tref t -> default_value t | Tarray _ -> Enew_array (ty,[]) diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index 173388e..d575be6 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -42,7 +42,6 @@ let rec _ty size ff t = match t with | Tclass n -> class_name ff n | Tgeneric (n, ty_l) -> fprintf ff "%a<@[%a@]>" class_name n (print_list_r ty """,""") ty_l | Tarray (t,s) -> if size then fprintf ff "%a[%a]" full_ty t exp s else fprintf ff "%a[]" ty t - | Tref t -> ty ff t | Tunit -> pp_print_string ff "void" and full_ty ff t = _ty true ff t diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index 717413d..7cbd40e 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -114,28 +114,28 @@ let rec static_exp param_env se = match se.Types.se_desc with | 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 + | 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 (t,size) -> Tarray (boxed_ty param_env t, static_exp param_env size) - | Types.Tmutable t -> Tref (boxed_ty param_env t) - | Types.Tunit -> Tunit + | Types.Tinvalid -> Misc.internal_error "obc2java invalid type" 1 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 :Java.ty = 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 (t,size) -> Tarray (ty param_env t, static_exp param_env size) - | Types.Tmutable t -> Tref (ty param_env t) - | Types.Tunit -> Tunit + | Types.Tinvalid -> Misc.internal_error "obc2java invalid type" 1 and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident } diff --git a/compiler/obc/main/obc_compiler.ml b/compiler/obc/main/obc_compiler.ml index 583404f..9eb9cea 100644 --- a/compiler/obc/main/obc_compiler.ml +++ b/compiler/obc/main/obc_compiler.ml @@ -16,6 +16,6 @@ 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 - (*Scalarize*) - let p = pass "Scalarize" !do_scalarize Scalarize.program p pp in +(* (*Scalarize*) + let p = pass "Scalarize" !do_scalarize Scalarize.program p pp in *) p diff --git a/compiler/obc/obc_utils.ml b/compiler/obc/obc_utils.ml index ad76213..dfb06c3 100644 --- a/compiler/obc/obc_utils.ml +++ b/compiler/obc/obc_utils.ml @@ -49,7 +49,7 @@ let mk_block ?(locals=[]) eq_list = b_body = eq_list } let mk_ifthenelse cond true_act false_act = - Acase (cond, [ ptrue, mk_block [true_act]; pfalse, mk_block [false_act] ]) + Acase (cond, [ Initial.ptrue, mk_block [true_act]; Initial.pfalse, mk_block [false_act] ]) let rec var_name x = match x.pat_desc with @@ -73,12 +73,10 @@ let rec vd_find n = function (** Returns the type of a [var_dec list] *) let vd_list_to_type vd_l = match vd_l with - | [] -> Types.Tunit | [vd] -> vd.v_type | _ -> Tprod (List.map (fun vd -> vd.v_type) vd_l) let pattern_list_to_type p_l = match p_l with - | [] -> Types.Tunit | [p] -> p.pat_ty | _ -> Tprod (List.map (fun p -> p.pat_ty) p_l) @@ -178,6 +176,7 @@ let fresh_for pass down up body = let ei = mk_evar_int i in Afor (id, down, up, mk_block (body ei)) +(* (** Creates the action copying [src] to [dest].*) let rec copy_array pass dest src = match dest.l_ty with | Tarray (t, n) -> @@ -189,3 +188,4 @@ let rec copy_array pass dest src = match dest.l_ty with fresh_for pass (mk_static_int 0) n copy | _ -> Aassgn(dest, Epattern src) +*) \ No newline at end of file diff --git a/compiler/obc/transformations/scalarize.ml b/compiler/obc/transformations/scalarize.ml index 04022f7..9a8d117 100644 --- a/compiler/obc/transformations/scalarize.ml +++ b/compiler/obc/transformations/scalarize.ml @@ -22,7 +22,7 @@ let fresh_for = fresh_for "scalarize" let act funs () a = match a with | Aassgn (p,e) -> (match e.e_ty with - | Types.Tarray (t, size) -> + | Types.Tarray (t, size) -> (* TODO ayayayaye *) (* a reference (alias) to the array, since we could have a full expression *) let array_ref = Idents.gen_var "scalarize" "a_ref" in let vd_array_ref = mk_var_dec array_ref (Types.Tmutable p.pat_ty) in