From d6240e1c67f159e75b78dae15376366e9996491d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Tue, 19 Apr 2011 18:45:56 +0200 Subject: [PATCH] 100 and java scalarized --- compiler/heptagon/analysis/typing.ml | 12 ++-- compiler/heptagon/hept_mapfold.ml | 12 ++-- compiler/heptagon/hept_printer.ml | 6 +- compiler/heptagon/heptagon.ml | 10 +-- compiler/heptagon/parsing/hept_parser.mly | 6 +- compiler/heptagon/parsing/hept_parsetree.ml | 8 +-- .../parsing/hept_parsetree_mapfold.ml | 22 +++---- compiler/heptagon/parsing/hept_scoping.ml | 14 ++--- compiler/main/mls2obc.ml | 18 +++--- compiler/main/mls2seq.ml | 2 +- compiler/minils/minils.ml | 6 +- compiler/minils/mls_mapfold.ml | 10 +-- compiler/minils/mls_printer.ml | 10 +-- compiler/minils/transformations/callgraph.ml | 20 +++--- compiler/obc/java/java_main.ml | 11 ++-- compiler/obc/java/obc2java.ml | 62 ++++++++++++------- compiler/obc/main/obc_compiler.ml | 4 +- compiler/obc/obc.ml | 6 +- compiler/obc/obc_mapfold.ml | 10 +-- compiler/obc/obc_printer.ml | 4 +- compiler/obc/transformations/scalarize.ml | 11 +++- 21 files changed, 141 insertions(+), 123 deletions(-) diff --git a/compiler/heptagon/analysis/typing.ml b/compiler/heptagon/analysis/typing.ml index 199891b..fbd3854 100644 --- a/compiler/heptagon/analysis/typing.ml +++ b/compiler/heptagon/analysis/typing.ml @@ -1097,9 +1097,9 @@ let typing_const_dec cd = { cd with c_value = se; c_type = ty } let program p = - let program_desc pd = match pd with - | Pnode n -> Pnode (node n) - | Pconst c -> Pconst (typing_const_dec c) - | _ -> pd - in - { p with p_desc = List.map program_desc p.p_desc } + let program_desc pd = match pd with + | Pnode n -> Pnode (node n) + | Pconst c -> Pconst (typing_const_dec c) + | _ -> pd + in + { p with p_desc = List.map program_desc p.p_desc } diff --git a/compiler/heptagon/hept_mapfold.ml b/compiler/heptagon/hept_mapfold.ml index 298e552..3b27e08 100644 --- a/compiler/heptagon/hept_mapfold.ml +++ b/compiler/heptagon/hept_mapfold.ml @@ -72,7 +72,7 @@ type 'a hept_it_funs = { node_dec : 'a hept_it_funs -> 'a -> node_dec -> node_dec * 'a; const_dec : 'a hept_it_funs -> 'a -> const_dec -> const_dec * 'a; program : 'a hept_it_funs -> 'a -> program -> program * 'a; - program_desc : 'a hept_it_funs -> 'a -> program_desc -> program_desc * 'a; + program_desc : 'a hept_it_funs -> 'a -> program_desc -> program_desc * 'a; global_funs : 'a Global_mapfold.global_it_funs } @@ -284,9 +284,9 @@ and program_desc_it funs acc pd = try funs.program_desc funs acc pd with Fallback -> program_desc funs acc pd and program_desc funs acc pd = match pd with - | Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc - | Ptype td -> (*let td, acc = Global_mapfold.ty_it funs.global_funs acc td in Ptype td, acc*) pd, acc - | Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc + | Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc + | Ptype td -> pd, acc + | Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc let defaults = { app = app; @@ -307,7 +307,7 @@ let defaults = { node_dec = node_dec; const_dec = const_dec; program = program; - program_desc = program_desc; + program_desc = program_desc; global_funs = Global_mapfold.defaults } @@ -331,7 +331,7 @@ let defaults_stop = { node_dec = stop; const_dec = stop; program = stop; - program_desc = stop; + program_desc = stop; global_funs = Global_mapfold.defaults_stop } diff --git a/compiler/heptagon/hept_printer.ml b/compiler/heptagon/hept_printer.ml index 4cf1bf0..bd324ec 100644 --- a/compiler/heptagon/hept_printer.ml +++ b/compiler/heptagon/hept_printer.ml @@ -290,9 +290,9 @@ let print_node ff print_eq_list nb.b_equs let print_pdesc ff pd = match pd with - | Pnode n -> print_node ff n - | Pconst c -> print_const_dec ff c - | Ptype t -> print_type_def ff t + | Pnode n -> print_node ff n + | Pconst c -> print_const_dec ff c + | Ptype t -> print_type_def ff t let print_open_module ff name = fprintf ff "open %s@." (modul_to_string name) diff --git a/compiler/heptagon/heptagon.ml b/compiler/heptagon/heptagon.ml index 5816079..4cd3924 100644 --- a/compiler/heptagon/heptagon.ml +++ b/compiler/heptagon/heptagon.ml @@ -161,12 +161,12 @@ type const_dec = { type program = { p_modname : modul; p_opened : modul list; - p_desc : program_desc list } - + p_desc : program_desc list } + and program_desc = - | Ptype of type_dec - | Pnode of node_dec - | Pconst of const_dec + | Ptype of type_dec + | Pnode of node_dec + | Pconst of const_dec type signature = { diff --git a/compiler/heptagon/parsing/hept_parser.mly b/compiler/heptagon/parsing/hept_parser.mly index 2043221..e3ad86f 100644 --- a/compiler/heptagon/parsing/hept_parser.mly +++ b/compiler/heptagon/parsing/hept_parser.mly @@ -116,16 +116,16 @@ program: o=list(opens) p=list(program_desc) EOF { {p_modname = ""; p_opened = o; program_desc: | p=PRAGMA { Ppragma p } - | c=const_dec { Pconst c } + | c=const_dec { Pconst c } | t=type_dec { Ptype t } - | n=node_dec { Pnode n } + | n=node_dec { Pnode n } ; opens: OPEN m=modul { m } const_dec: | CONST x=IDENT COLON t=ty_ident EQUAL e=exp - { mk_const_dec x t e (Loc($startpos,$endpos)) } + { mk_const_dec x t e (Loc($startpos,$endpos)) } ; type_dec: diff --git a/compiler/heptagon/parsing/hept_parsetree.ml b/compiler/heptagon/parsing/hept_parsetree.ml index 7b48c9e..f567ddb 100644 --- a/compiler/heptagon/parsing/hept_parsetree.ml +++ b/compiler/heptagon/parsing/hept_parsetree.ml @@ -180,13 +180,13 @@ type const_dec = type program = { p_modname : dec_name; - p_opened : module_name list; + p_opened : module_name list; p_desc : program_desc list } and program_desc = - | Ppragma of (var_name * string) - | Ptype of type_dec - | Pconst of const_dec + | Ppragma of (var_name * string) + | Ptype of type_dec + | Pconst of const_dec | Pnode of node_dec diff --git a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml index c094b68..73e5410 100644 --- a/compiler/heptagon/parsing/hept_parsetree_mapfold.ml +++ b/compiler/heptagon/parsing/hept_parsetree_mapfold.ml @@ -17,7 +17,7 @@ type 'a hept_it_funs = { ty : 'a hept_it_funs -> 'a -> Hept_parsetree.ty -> Hept_parsetree.ty * 'a; static_exp : 'a hept_it_funs -> 'a -> Hept_parsetree.static_exp -> static_exp * 'a; static_exp_desc : 'a hept_it_funs -> 'a -> Hept_parsetree.static_exp_desc - -> Hept_parsetree.static_exp_desc * 'a; + -> Hept_parsetree.static_exp_desc * 'a; app: 'a hept_it_funs -> 'a -> Hept_parsetree.app -> Hept_parsetree.app * 'a; block: 'a hept_it_funs -> 'a -> Hept_parsetree.block -> Hept_parsetree.block * 'a; edesc: 'a hept_it_funs -> 'a -> Hept_parsetree.edesc -> Hept_parsetree.edesc * 'a; @@ -42,7 +42,7 @@ type 'a hept_it_funs = { type_desc: 'a hept_it_funs -> 'a -> Hept_parsetree.type_desc -> Hept_parsetree.type_desc * 'a; program: 'a hept_it_funs -> 'a -> Hept_parsetree.program -> Hept_parsetree.program * 'a; program_desc: 'a hept_it_funs -> 'a -> Hept_parsetree.program_desc - -> Hept_parsetree.program_desc * 'a; } + -> Hept_parsetree.program_desc * 'a; } let rec static_exp_it funs acc se = funs.static_exp funs acc se and static_exp funs acc se = @@ -298,17 +298,17 @@ and type_desc funs acc td = match td with and program_it funs acc p = funs.program funs acc p and program funs acc p = - let p_desc, acc = mapfold (program_desc funs) acc p.p_desc in - { p with p_desc = p_desc }, acc - + let p_desc, acc = mapfold (program_desc funs) acc p.p_desc in + { p with p_desc = p_desc }, acc + and program_desc_it funs acc pd = - try funs.program_desc funs acc pd - with Fallback -> program_desc funs acc pd + try funs.program_desc funs acc pd + with Fallback -> program_desc funs acc pd and program_desc funs acc pd = match pd with - | Pconst c -> let c, acc = const_dec_it funs acc c in Pconst c, acc + | Pconst c -> let c, acc = const_dec_it funs acc c in Pconst c, acc | Ptype t -> let t, acc = type_dec_it funs acc t in Ptype t, acc | Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc - | Ppragma _ -> pd, acc + | Ppragma _ -> pd, acc let defaults = { ty = ty; @@ -334,7 +334,7 @@ let defaults = { type_dec = type_dec; type_desc = type_desc; program = program; - program_desc = program_desc } + program_desc = program_desc } @@ -362,5 +362,5 @@ let defaults_stop = { type_dec = stop; type_desc = stop; program = stop; - program_desc = stop } + program_desc = stop } diff --git a/compiler/heptagon/parsing/hept_scoping.ml b/compiler/heptagon/parsing/hept_scoping.ml index eb9b813..61ad4e6 100644 --- a/compiler/heptagon/parsing/hept_scoping.ml +++ b/compiler/heptagon/parsing/hept_scoping.ml @@ -454,14 +454,14 @@ let translate_const_dec cd = Heptagon.c_loc = cd.c_loc; } let translate_program p = - let translate_program_desc pd = match pd with - | Ppragma _ -> Misc.unsupported "pragma in scoping" 1 - | Pconst c -> Heptagon.Pconst (translate_const_dec c) - | Ptype t -> Heptagon.Ptype (translate_typedec t) - | Pnode n -> Heptagon.Pnode (translate_node n) - in + let translate_program_desc pd = match pd with + | Ppragma _ -> Misc.unsupported "pragma in scoping" 1 + | Pconst c -> Heptagon.Pconst (translate_const_dec c) + | Ptype t -> Heptagon.Ptype (translate_typedec t) + | Pnode n -> Heptagon.Pnode (translate_node n) + in List.iter open_module p.p_opened; - let desc = List.map translate_program_desc p.p_desc in + let desc = List.map translate_program_desc p.p_desc in { Heptagon.p_modname = Names.modul_of_string p.p_modname; Heptagon.p_opened = p.p_opened; Heptagon.p_desc = desc; } diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index a6a10de..93862f0 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -25,11 +25,11 @@ let build_anon, find_anon = let anon_nodes = ref QualEnv.empty in let build_anon nodes = let build env nd = match nd with - | Minils.Pnode nd -> + | Minils.Pnode nd -> if Itfusion.is_anon_node nd.Minils.n_name then QualEnv.add nd.Minils.n_name nd env else env - | _ -> env + | _ -> env in anon_nodes := List.fold_left build QualEnv.empty nodes in @@ -642,14 +642,14 @@ let program { Minils.p_modname = p_modname; Minils.p_opened = p_o; Minils.p_desc build_anon pd; let program_desc pd acc = match pd with - | Minils.Pnode n when not (Itfusion.is_anon_node n.Minils.n_name) -> - Pclass (translate_node n) :: acc + | Minils.Pnode n when not (Itfusion.is_anon_node n.Minils.n_name) -> + Pclass (translate_node n) :: acc (* dont't translate anonymous nodes, they will be inlined *) - | Minils.Pnode n -> acc - | Minils.Ptype t -> Ptype (translate_ty_def t) :: acc - | Minils.Pconst c -> Pconst (translate_const_def c) :: acc - in - let p_desc = List.fold_right program_desc pd [] in + | Minils.Pnode n -> acc + | Minils.Ptype t -> Ptype (translate_ty_def t) :: acc + | Minils.Pconst c -> Pconst (translate_const_def c) :: acc + in + let p_desc = List.fold_right program_desc pd [] in { p_modname = p_modname; p_opened = p_o; p_desc = p_desc } diff --git a/compiler/main/mls2seq.ml b/compiler/main/mls2seq.ml index 09d4c2b..1484058 100644 --- a/compiler/main/mls2seq.ml +++ b/compiler/main/mls2seq.ml @@ -41,7 +41,7 @@ let write_obc_file p = let no_conf () = () let targets = [ "c",(Obc_no_params Cmain.program, no_conf); - "java", (Obc Java_main.program, Java_main.java_conf); + "java", (Obc Java_main.program, no_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 a1c9be9..4996bd2 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -141,9 +141,9 @@ type program = { p_desc : program_desc list } and program_desc = - | Pnode of node_dec - | Pconst of const_dec - | Ptype of type_dec + | Pnode of node_dec + | Pconst of const_dec + | Ptype of type_dec (*Helper functions to build the AST*) diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index 4fff883..2575d0d 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -33,7 +33,7 @@ type 'a mls_it_funs = { 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; - program_desc: 'a mls_it_funs -> 'a -> Minils.program_desc -> Minils.program_desc * 'a; + program_desc: 'a mls_it_funs -> 'a -> Minils.program_desc -> Minils.program_desc * 'a; global_funs: 'a Global_mapfold.global_it_funs } @@ -197,9 +197,9 @@ and program_desc_it funs acc pd = try funs.program_desc funs acc pd with Fallback -> program_desc funs acc pd and program_desc funs acc pd = match pd with - | Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc - | Ptype td -> let td, acc = type_dec_it funs acc td in Ptype td, acc - | Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc + | Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc + | Ptype td -> let td, acc = type_dec_it funs acc td in Ptype td, acc + | Pnode n -> let n, acc = node_dec_it funs acc n in Pnode n, acc let defaults = { @@ -219,5 +219,5 @@ let defaults = { type_dec = type_dec; tdesc = tdesc; program = program; - program_desc = program_desc; + program_desc = program_desc; global_funs = Global_mapfold.defaults } diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index e5f1e75..40ad008 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -227,11 +227,11 @@ let print_node ff { n_name = n; n_input = ni; n_output = no; let print oc { p_opened = pm; p_desc = pd } = let print_program_desc ff pd = match pd with - | Pnode n -> print_node ff n - | Ptype t -> print_type_dec ff t - | Pconst c -> print_const_dec ff c - in - let ff = formatter_of_out_channel oc in + | Pnode n -> print_node ff n + | Ptype t -> print_type_dec ff t + | Pconst c -> print_const_dec ff c + in + let ff = formatter_of_out_channel oc in List.iter (print_open_module ff) pm; List.iter (print_program_desc ff) pd; fprintf ff "@?" diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index 465143c..2a68a18 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -193,12 +193,12 @@ struct List.map (node_dec_instance n) (get_node_instances n.n_name) let program p = - let program_desc pd acc = match pd with - | Pnode n -> - let nds = node_dec n in - List.fold_left (fun pds n -> Pnode n :: pds) acc nds - | _ -> pd :: acc - in + let program_desc pd acc = match pd with + | Pnode n -> + let nds = node_dec n in + List.fold_left (fun pds n -> Pnode n :: pds) acc nds + | _ -> pd :: acc + in { p with p_desc = List.fold_right program_desc p.p_desc [] } end @@ -259,9 +259,9 @@ let node_by_longname node = try let p = ModulEnv.find node.qual info.opened in let n = List.find (function Pnode n -> n.n_name = node | _ -> false) p.p_desc in - (match n with - | Pnode n -> n - | _ -> Misc.internal_error "callgraph" 0) + (match n with + | Pnode n -> n + | _ -> Misc.internal_error "callgraph" 0) with Not_found -> Error.message no_location (Error.Enode_unbound node) @@ -318,7 +318,7 @@ let program p = (* Find the nodes without static parameters *) let main_nodes = List.filter (function Pnode n -> is_empty n.n_params | _ -> false) p.p_desc in let main_nodes = List.map (function Pnode n -> n.n_name, [] - | _ -> Misc.internal_error "callgraph" 0) main_nodes in + | _ -> Misc.internal_error "callgraph" 0) main_nodes in info.opened <- ModulEnv.add p.p_modname p ModulEnv.empty; (* Creates the list of instances starting from these nodes *) List.iter call_node main_nodes; diff --git a/compiler/obc/java/java_main.ml b/compiler/obc/java/java_main.ml index 8a0776a..db160fd 100644 --- a/compiler/obc/java/java_main.ml +++ b/compiler/obc/java/java_main.ml @@ -3,15 +3,14 @@ open Signature open Java open Java_printer -let java_conf () = - Compiler_options.do_scalarize := true - (** returns the vd and the pat of a fresh ident from [name] *) let mk_var ty name = let id = Idents.gen_var "java_main" name in mk_var_dec id ty, Pvar id let program p = + (*Scalarize*) + let p = Compiler_utils.pass "Scalarize" true Scalarize.program p Obc_compiler.pp in let p_java = Obc2java.program p in let dir = Compiler_utils.build_path "java" in Compiler_utils.ensure_dir dir; @@ -30,11 +29,13 @@ let program p = in let main_methode = let vd_step, pat_step = mk_var Tint "step" in - let vd_args, pat_args = mk_var (Tarray (Tclass (Names.pervasives_qn "String"), (Sint 0))) "args" in + let vd_args, pat_args = + mk_var (Tarray (Tclass (Names.pervasives_qn "String"), (Sint 0))) "args" in let body = let vd_main, e_main, q_main, ty_main = let q_main = !Compiler_options.simulation_node |> Modules.qualify_value in (*qual*) - let ty_main = (Modules.find_value q_main).node_outputs |> types_of_arg_list |> Types.prod in + let ty_main = + (Modules.find_value q_main).node_outputs |> types_of_arg_list |> Types.prod in let q_main = Obc2java.qualname_to_package_classe q_main in (*java qual*) let id = Idents.gen_var "java_main" "main" in mk_var_dec id (Tclass q_main), Eval (Pvar id), q_main, ty_main diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index f1cfbd9..36c5549 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -15,8 +15,8 @@ Obc.Oobj and Oarray are simply Pvar and Parray_elem Obc.Types_alias are dereferenced since no simple type alias is possible in Java *) -(** Requires scalar Obc : [p = e] when [e] is an array is understand as a copy of the reference, - not a copy of the array. *) +(** Requires scalarized Obc : + [p = e] when [e] is an array is understand as a copy of the reference, not a copy of the array.*) open Format open Misc @@ -34,19 +34,22 @@ let add_classe, get_classes = (fun c -> extra_classes := c :: !extra_classes) ,(fun () -> !extra_classes) -(** fresh Afor from 0 to [size] with [body] a function from [var_ident] (the iterator) to [act] list *) +(** 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 = Idents.gen_var "obc2java" "i" in let id = mk_var_dec i Tint in Afor (id, Sint 0, size, mk_block (body i)) - (* current module is not translated to keep track, there is no issue since printed without the qualifier *) + (* current module is not translated to keep track, + there is no issue since printed without the qualifier *) let rec translate_modul m = match m with | Pervasives | LocalModule -> m | _ when m = g_env.current_mod -> m | Module n -> Module (String.lowercase n) - | QualModule { qual = q; name = n} -> QualModule { qual = translate_modul q; name = String.lowercase n } + | QualModule { qual = q; name = n} -> + QualModule { qual = translate_modul q; name = String.lowercase n } (** a [Module.const] becomes a [module.CONSTANTES.CONST] *) let translate_const_name { qual = m; name = n } = @@ -68,7 +71,8 @@ let qualname_to_package_classe q = (** Create a fresh class qual from a name *) let fresh_classe n = Modules.fresh_value "obc2java" n |> qualname_to_package_classe -(** 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_2 q q_ty = let classe = qualname_to_class_name q_ty in { qual = QualModule classe; name = String.uppercase q.name } @@ -109,7 +113,8 @@ let rec static_exp param_env se = match se.Types.se_desc with in let se_l = Misc.repeat_list (static_exp param_env see) pow in Enew_array (ty param_env se.Types.se_ty, se_l) - | Types.Sarray se_l -> Enew_array (ty param_env se.Types.se_ty, List.map (static_exp param_env) se_l) + | 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) @@ -270,7 +275,8 @@ let class_def_list classes cd_l = in (* [reset] is the reset method of the class, [reset_mems] is the block to reset the members of the class - without call to the reset method of inner instances, it retains [this.x = 0] but not [this.I.reset()] *) + without call to the reset method of inner instances, + it retains [this.x = 0] but not [this.I.reset()] *) let reset, reset_mems = try (* When there exist a reset method *) let oreset = find_reset_method cd in @@ -280,7 +286,8 @@ let class_def_list classes cd_l = with Not_found -> (* stub reset method *) mk_methode (mk_block []) "reset", mk_block [] in - (* [obj_env] gives the type of an [obj_ident], needed in async because we change the classe for async obj *) + (* [obj_env] gives the type of an [obj_ident], + needed in async because we change the classe for async obj *) let constructeur, obj_env = let obj_env = (* Mapping between Obc class and Java class, useful at least with asyncs *) let aux obj_env od = @@ -299,7 +306,9 @@ let class_def_list classes cd_l = | Some size -> let size = static_exp param_env size in let t = Idents.Env.find od.o_ident obj_env in - let assgn_elem i = [ Aassgn (Parray_elem (Pthis od.o_ident, mk_var i), Enew (t, params)) ] in + let assgn_elem i = + [ Aassgn (Parray_elem (Pthis od.o_ident, mk_var i), Enew (t, params)) ] + in (Aassgn (Pthis od.o_ident, Enew_array (Tarray (t,size), []))) :: (fresh_for size assgn_elem) :: acts @@ -324,7 +333,9 @@ let class_def_list classes cd_l = in mk_methode ~args:vds_params body (shortname class_name), obj_env in 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 = let jty = match od.o_size with | None -> Idents.Env.find od.o_ident obj_env @@ -340,10 +351,11 @@ let class_def_list classes cd_l = let ostep = find_step_method cd in let vd_output = var_dec_list param_env ostep.m_outputs in let return_ty = ostep.m_outputs |> vd_list_to_type |> (ty param_env) in - let return_act = Areturn (match vd_output with - | [] -> Evoid - | [vd] -> Eval (Pvar vd.vd_ident) - | vd_l -> Enew (return_ty, List.map (fun vd -> Eval (Pvar vd.vd_ident)) vd_l)) + let return_act = + Areturn (match vd_output with + | [] -> Evoid + | [vd] -> Eval (Pvar vd.vd_ident) + | vd_l -> Enew (return_ty, List.map (fun vd -> Eval (Pvar vd.vd_ident)) vd_l)) in let body = block param_env ~locals:vd_output ~end_acts:[return_act] ostep.Obc.m_body in mk_methode ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step" @@ -371,7 +383,8 @@ let type_dec_list classes td_l = let jty = ty param_env oty in let field = Idents.ident_of_name (translate_field_name oname) in (* [translate_field_name] will give the right result anywhere it is used, - since the [ident_of_name] will keep it as it is unique in the class, see [Idents.enter_node classe_name] *) + since the [ident_of_name] will keep it as it is unique in the class, + see [Idents.enter_node classe_name] *) mk_field jty field in (mk_classe ~fields:(List.map mk_field_jfield f_l) classe_name) :: classes @@ -387,7 +400,8 @@ let const_dec_list cd_l = match cd_l with let param_env = NamesEnv.empty in let mk_const_field { Obc.c_name = oname ; Obc.c_value = ovalue; Obc.c_type = otype } = let name = oname |> translate_const_name |> shortname |> Idents.ident_of_name in - (* name should always keep the shortname unchanged since we enter a special node free of existing variables *) + (* name should always keep the shortname unchanged + since we enter a special node free of existing variables *) (* thus [translate_const_name] will gives the right result anywhere it is used. *) let value = Some (static_exp param_env ovalue) in let t = ty param_env otype in @@ -399,13 +413,13 @@ let const_dec_list cd_l = match cd_l with let program p = - let rec program_descs pds (ns,cs,ts) = match pds with - | [] -> ns,cs,ts - | Obc.Pclass n :: pds -> program_descs pds (n::ns,cs,ts) - | Obc.Pconst c :: pds -> program_descs pds (ns,c::cs,ts) - | Obc.Ptype t :: pds -> program_descs pds (ns,cs,t::ts) - in - let ns,cs,ts = program_descs p.p_desc ([],[],[]) in + let rec program_descs pds (ns,cs,ts) = match pds with + | [] -> ns,cs,ts + | Obc.Pclass n :: pds -> program_descs pds (n::ns,cs,ts) + | Obc.Pconst c :: pds -> program_descs pds (ns,c::cs,ts) + | Obc.Ptype t :: pds -> program_descs pds (ns,cs,t::ts) + in + let ns,cs,ts = program_descs p.p_desc ([],[],[]) in let classes = const_dec_list cs in let classes = type_dec_list classes ts in let p = class_def_list classes ns in diff --git a/compiler/obc/main/obc_compiler.ml b/compiler/obc/main/obc_compiler.ml index 9eb9cea..686e3c7 100644 --- a/compiler/obc/main/obc_compiler.ml +++ b/compiler/obc/main/obc_compiler.ml @@ -16,6 +16,4 @@ 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 *) - p + p diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index bbfc9cb..a0f9703 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -114,7 +114,7 @@ type program = p_desc : program_desc list } and program_desc = - | Pclass of class_def - | Pconst of const_dec - | Ptype of type_dec + | Pclass of class_def + | Pconst of const_dec + | Ptype of type_dec diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index 627e180..1f49d00 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -29,7 +29,7 @@ type 'a obc_it_funs = { type_dec: 'a obc_it_funs -> 'a -> Obc.type_dec -> Obc.type_dec * 'a; tdesc: 'a obc_it_funs -> 'a -> Obc.tdesc -> Obc.tdesc * 'a; program: 'a obc_it_funs -> 'a -> Obc.program -> Obc.program * 'a; - program_desc: 'a obc_it_funs -> 'a -> Obc.program_desc -> Obc.program_desc * 'a; + program_desc: 'a obc_it_funs -> 'a -> Obc.program_desc -> Obc.program_desc * 'a; global_funs: 'a Global_mapfold.global_it_funs } @@ -192,9 +192,9 @@ and program_desc_it funs acc pd = try funs.program_desc funs acc pd with Fallback -> program_desc funs acc pd and program_desc funs acc pd = match pd with - | Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc - | Ptype td -> let td, acc = type_dec_it funs acc td in Ptype td, acc - | Pclass n -> let n, acc = class_def_it funs acc n in Pclass n, acc + | Pconst cd -> let cd, acc = const_dec_it funs acc cd in Pconst cd, acc + | Ptype td -> let td, acc = type_dec_it funs acc td in Ptype td, acc + | Pclass n -> let n, acc = class_def_it funs acc n in Pclass n, acc let defaults = { lhs = lhs; @@ -213,5 +213,5 @@ let defaults = { type_dec = type_dec; tdesc = tdesc; program = program; - program_desc = program_desc; + program_desc = program_desc; global_funs = Global_mapfold.defaults } diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 03e3833..d068ac9 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -181,8 +181,8 @@ let print_const_dec ff c = let print_prog_desc ff pd = match pd with | Pclass cd -> print_class_def ff cd; fprintf ff "@\n@\n" - | Pconst cd -> print_const_dec ff cd - | Ptype td -> print_type_def ff td + | Pconst cd -> print_const_dec ff cd + | Ptype td -> print_type_def ff td let print_prog ff { p_opened = modules; p_desc = descs } = List.iter (print_open_module ff) modules; diff --git a/compiler/obc/transformations/scalarize.ml b/compiler/obc/transformations/scalarize.ml index 9a8d117..969bbc6 100644 --- a/compiler/obc/transformations/scalarize.ml +++ b/compiler/obc/transformations/scalarize.ml @@ -17,15 +17,20 @@ open Obc open Obc_utils open Obc_mapfold +(** Scalarize the code : any equation t = e with e_ty an array + is transformed into : t_ref = e; for i do t[i] = t_ref[i]. + This pass assumes that the backend when encountering t_ref = (e : int^n) will NOT COPY the array + but set a reference to it. *) + 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) -> (* TODO ayayayaye *) + | Types.Tarray (t, size) -> (* 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 + let vd_array_ref = mk_var_dec array_ref p.pat_ty in (* reference initialization *) let pat_array_ref = mk_pattern ~loc:e.e_loc p.pat_ty (Lvar array_ref) in let init_array_ref = Aassgn (pat_array_ref, e) in @@ -38,7 +43,7 @@ let act funs () a = match a with let a, _ = act_it funs () a in [a] in - let copy_array = fresh_for size copy_i in + let copy_array = fresh_for (mk_exp_const_int 0) (mk_exp_static_int size) copy_i in (* resulting block *) let block = mk_block ~locals:[vd_array_ref] [init_array_ref; copy_array] in Ablock block, ()