jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

100 and java scalarized

Browse source
This commit is contained in:
Léonard Gérard 2011-04-19 18:45:56 +02:00
parent 802178fb28
commit d6240e1c67
21 changed files with 141 additions and 123 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
compiler/heptagon/analysis/typing.ml
View file

@ -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 }

12
compiler/heptagon/hept_mapfold.ml
View file

@ -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 }

6
compiler/heptagon/hept_printer.ml
View file

@ -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)

10
compiler/heptagon/heptagon.ml
View file

@ -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 = {

6
compiler/heptagon/parsing/hept_parser.mly
View file

@ -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:

8
compiler/heptagon/parsing/hept_parsetree.ml
View file

@ -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

22
compiler/heptagon/parsing/hept_parsetree_mapfold.ml
View file

@ -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 }

14
compiler/heptagon/parsing/hept_scoping.ml
View file

@ -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; }

18
compiler/main/mls2obc.ml
View file

@ -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 }

2
compiler/main/mls2seq.ml
View file

@ -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) ]

6
compiler/minils/minils.ml
View file

@ -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*)

10
compiler/minils/mls_mapfold.ml
View file

@ -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 }

10
compiler/minils/mls_printer.ml
View file

@ -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 "@?"

20
compiler/minils/transformations/callgraph.ml
View file

@ -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;

11
compiler/obc/java/java_main.ml
View file

@ -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

62
compiler/obc/java/obc2java.ml
View file

@ -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

4
compiler/obc/main/obc_compiler.ml
View file

@ -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

6
compiler/obc/obc.ml
View file

@ -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

10
compiler/obc/obc_mapfold.ml
View file

@ -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 }

4
compiler/obc/obc_printer.ml
View file

@ -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;

11
compiler/obc/transformations/scalarize.ml
View file

@ -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, ()