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

jeudi soir. still on mls2obc.

Browse source
This commit is contained in:
Léonard Gérard 2011-04-14 18:06:54 +02:00
parent f57d7f1589
commit 5d2f7dfa85
22 changed files with 170 additions and 159 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
compiler/global/clocks.ml
View file

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

5
compiler/global/global_mapfold.ml
View file

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

5
compiler/global/global_printer.ml
View file

@ -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 "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
| Tid id -> print_qualname ff id
| Tarray (ty, n) ->
fprintf ff "@[<hov2>%a^%a@]" print_type ty print_static_exp n
| Tmutable ty ->
fprintf ff "@[<hov2>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

6
compiler/global/initial.ml
View file

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

3
compiler/global/modules.ml
View file

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

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

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

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

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

2
compiler/heptagon/transformations/automata.ml
View file

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

60
compiler/main/mls2obc.ml
View file

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

4
compiler/main/mls2seq.ml
View file

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

7
compiler/minils/minils.ml
View file

@ -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 <<a_params>> (args) reset r *)
| Enode of fun_name (** "Stateful" longname <<a_params>> (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))

101
compiler/minils/mls_mapfold.ml
View file

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

84
compiler/minils/mls_printer.ml
View file

@ -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 "@[<hv>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 } =

8
compiler/minils/mls_utils.ml
View file

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

3
compiler/obc/c/cgen.ml
View file

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

4
compiler/obc/c/cmain.ml
View file

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

2
compiler/obc/java/java.ml
View file

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

1
compiler/obc/java/java_printer.ml
View file

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

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

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

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

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

6
compiler/obc/obc_utils.ml
View file

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

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

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