jeudi soir. still on mls2obc.
This commit is contained in:
parent
f57d7f1589
commit
5d2f7dfa85
|
@ -90,13 +90,10 @@ and unify_list t1_list t2_list =
|
||||||
let rec skeleton ck = function
|
let rec skeleton ck = function
|
||||||
| Tprod ty_list ->
|
| Tprod ty_list ->
|
||||||
(match ty_list with
|
(match ty_list with
|
||||||
| [] ->
|
| [] -> Ck ck
|
||||||
Format.eprintf "Internal error, an exp with invalid type@.";
|
|
||||||
assert false;
|
|
||||||
| _ -> Cprod (List.map (skeleton ck) ty_list))
|
| _ -> Cprod (List.map (skeleton ck) ty_list))
|
||||||
| Tarray (t, _) -> skeleton ck t
|
| Tarray (t, _) -> skeleton ck t
|
||||||
| Tmutable t -> skeleton ck t
|
| Tid _ | Tinvalid -> Ck ck
|
||||||
| Tid _ | Tunit -> Ck ck
|
|
||||||
|
|
||||||
(* TODO here it implicitely says that the base clock is Cbase
|
(* TODO here it implicitely says that the base clock is Cbase
|
||||||
and that all tuple is on Cbase *)
|
and that all tuple is on Cbase *)
|
||||||
|
|
|
@ -57,10 +57,7 @@ and ty funs acc t = match t with
|
||||||
let t, acc = ty_it funs acc t in
|
let t, acc = ty_it funs acc t in
|
||||||
let se, acc = static_exp_it funs acc se in
|
let se, acc = static_exp_it funs acc se in
|
||||||
Tarray (t, se), acc
|
Tarray (t, se), acc
|
||||||
| Tmutable t ->
|
| Tinvalid -> t, acc
|
||||||
let t, acc = ty_it funs acc t in
|
|
||||||
Tmutable t, acc
|
|
||||||
| Tunit -> t, acc
|
|
||||||
(*
|
(*
|
||||||
and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc t
|
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
|
and ct funs acc c = match c with
|
||||||
|
|
|
@ -64,15 +64,12 @@ and print_static_exp_tuple ff l =
|
||||||
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
|
fprintf ff "@[<2>%a@]" (print_list_r print_static_exp "("","")") l
|
||||||
|
|
||||||
and print_type ff = function
|
and print_type ff = function
|
||||||
| Tprod [] -> fprintf ff "INVALID TYPE"
|
| Tinvalid -> fprintf ff "INVALID TYPE"
|
||||||
| Tprod ty_list ->
|
| Tprod ty_list ->
|
||||||
fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
|
fprintf ff "@[<hov2>%a@]" (print_list_r print_type "(" " *" ")") ty_list
|
||||||
| Tid id -> print_qualname ff id
|
| Tid id -> print_qualname ff id
|
||||||
| Tarray (ty, n) ->
|
| Tarray (ty, n) ->
|
||||||
fprintf ff "@[<hov2>%a^%a@]" print_type ty print_static_exp 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 =
|
let print_field ff field =
|
||||||
fprintf ff "@[%a: %a@]" print_qualname field.f_name print_type field.f_type
|
fprintf ff "@[%a: %a@]" print_qualname field.f_name print_type field.f_type
|
||||||
|
|
|
@ -28,13 +28,13 @@ let tfloat = Types.Tid pfloat
|
||||||
let mk_pervasives s = { qual = Pervasives; name = s }
|
let mk_pervasives s = { qual = Pervasives; name = s }
|
||||||
|
|
||||||
let mk_static_int_op op args =
|
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 =
|
let mk_static_int i =
|
||||||
mk_static_exp ~ty:tint (Sint i)
|
mk_static_exp tint (Sint i)
|
||||||
|
|
||||||
let mk_static_bool b =
|
let mk_static_bool b =
|
||||||
mk_static_exp ~ty:tbool (Sbool b)
|
mk_static_exp tbool (Sbool b)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -291,8 +291,7 @@ let rec unalias_type t = match t with
|
||||||
with Not_found -> raise (Undefined_type ty_name))
|
with Not_found -> raise (Undefined_type ty_name))
|
||||||
| Tarray (ty, n) -> Tarray(unalias_type ty, n)
|
| Tarray (ty, n) -> Tarray(unalias_type ty, n)
|
||||||
| Tprod ty_list -> Tprod (List.map unalias_type ty_list)
|
| Tprod ty_list -> Tprod (List.map unalias_type ty_list)
|
||||||
| Tmutable t -> Tmutable (unalias_type t)
|
| Tinvalid -> Tinvalid
|
||||||
| Tunit -> Tunit
|
|
||||||
|
|
||||||
|
|
||||||
(** Return the current module as a [module_object] *)
|
(** Return the current module as a [module_object] *)
|
||||||
|
|
|
@ -257,7 +257,6 @@ let build_subst names values =
|
||||||
let rec subst_type_vars m = function
|
let rec subst_type_vars m = function
|
||||||
| Tarray(ty, e) -> Tarray(subst_type_vars m ty, simplify m e)
|
| Tarray(ty, e) -> Tarray(subst_type_vars m ty, simplify m e)
|
||||||
| Tprod l -> Tprod (List.map (subst_type_vars m) l)
|
| Tprod l -> Tprod (List.map (subst_type_vars m) l)
|
||||||
| Tmutable t -> Tmutable (subst_type_vars m t)
|
|
||||||
| t -> t
|
| t -> t
|
||||||
|
|
||||||
let add_distinct_env id ty env =
|
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 ? *)
|
| Tid ty_name -> Tid ty_name (* TODO bug ? should check that ty_name exists ? *)
|
||||||
| Tprod l ->
|
| Tprod l ->
|
||||||
Tprod (List.map (check_type const_env) l)
|
Tprod (List.map (check_type const_env) l)
|
||||||
| Tmutable t ->
|
| Tinvalid -> Tinvalid
|
||||||
Tmutable (check_type const_env t)
|
|
||||||
| Tunit -> Tunit
|
|
||||||
|
|
||||||
and typing_static_exp const_env se =
|
and typing_static_exp const_env se =
|
||||||
try
|
try
|
||||||
|
|
|
@ -181,7 +181,7 @@ let static_app_from_app app args=
|
||||||
let rec translate_static_exp se =
|
let rec translate_static_exp se =
|
||||||
try
|
try
|
||||||
let se_d = translate_static_exp_desc se.se_desc in
|
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
|
with
|
||||||
| ScopingError err -> message se.se_loc err
|
| ScopingError err -> message se.se_loc err
|
||||||
|
|
||||||
|
|
|
@ -40,7 +40,7 @@ let mk_exp_fby_false e =
|
||||||
(Tid Initial.pbool)
|
(Tid Initial.pbool)
|
||||||
|
|
||||||
let mk_constructor constr ty =
|
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 *)
|
(* Be sure that [initial] is of the right type [e.e_ty] before using this *)
|
||||||
let mk_exp_fby_state initial e =
|
let mk_exp_fby_state initial e =
|
||||||
|
|
|
@ -11,6 +11,7 @@
|
||||||
open Misc
|
open Misc
|
||||||
open Names
|
open Names
|
||||||
open Idents
|
open Idents
|
||||||
|
open Clocks
|
||||||
open Signature
|
open Signature
|
||||||
open Obc
|
open Obc
|
||||||
open Obc_utils
|
open Obc_utils
|
||||||
|
@ -32,7 +33,7 @@ let fresh_it () =
|
||||||
|
|
||||||
let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst")
|
let gen_obj_ident n = Idents.gen_var "mls2obc" ((shortname n) ^ "_inst")
|
||||||
let fresh_for = fresh_for "mls2obc"
|
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; }
|
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 "<",
|
let e1 = mk_exp_bool (Eop (op_from_string "<",
|
||||||
[idx; mk_exp_int (Econst n)])) in
|
[idx; mk_exp_int (Econst n)])) in
|
||||||
let e2 = mk_exp_bool (Eop (op_from_string "<=",
|
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]))
|
mk_exp_bool (Eop (op_from_string "&", [e1;e2]))
|
||||||
in
|
in
|
||||||
match (idx_list, bounds) with
|
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],
|
(** Creates the action list that copies [src] to [dest],
|
||||||
updating the value at index [idx_list] with the value [v]. *)
|
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 ->
|
| Tarray (t, n), idx::idx_list ->
|
||||||
(*Body of the copy loops*)
|
(*Body of the copy loops*)
|
||||||
let copy i =
|
let copy i =
|
||||||
let src_i = mk_pattern_exp t (Larray (src, i)) in
|
let src_i = mk_pattern_exp t (Larray (src, i)) in
|
||||||
let dest_i = mk_pattern t (Larray (dest, i)) in
|
let dest_i = mk_pattern t (Larray (dest, i)) in
|
||||||
[Aassgn(dest_i, src_i)]
|
[Aassgn(dest_i, src_i)]
|
||||||
in
|
in
|
||||||
|
|
||||||
(*Copy values < idx*)
|
(*Copy values < idx*)
|
||||||
let a_lower = fresh_for (mk_static_int 0) idx copy in
|
let a_lower = fresh_for (mk_static_int 0) idx copy in
|
||||||
|
|
||||||
(* Update the correct element*)
|
(* Update the correct element*)
|
||||||
let src_idx = mk_pattern_exp t (Larray (src, idx)) in
|
let src_idx = mk_pattern t (Larray (src, mk_exp_int (Econst idx))) in
|
||||||
let dest_idx = mk_pattern t (Larray (dest, 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 v idx_list in
|
let a_update = update_array dest_idx src_idx idx_list v in
|
||||||
|
|
||||||
(*Copy values > idx*)
|
(*Copy values > idx*)
|
||||||
let idx_plus_one = mk_static_int_op (mk_pervasives "+") [idx; mk_static_int 1] in
|
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
|
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)]
|
[Aassgn(dest, v)]
|
||||||
|
|
||||||
|
@ -121,9 +118,11 @@ let update_record dest src f v =
|
||||||
else
|
else
|
||||||
Aassgn(dest_l, src_l)
|
Aassgn(dest_l, src_l)
|
||||||
in
|
in
|
||||||
let n = struct_name dest.l_ty in
|
let fields = match dest.pat_ty with
|
||||||
let fields = find_struct n in
|
| Tid n -> Modules.find_struct n
|
||||||
List.map assgn_act fields
|
| _ -> Misc.internal_error "mls2obc field of nonstruct" 1
|
||||||
|
in
|
||||||
|
List.map assgn_act fields
|
||||||
|
|
||||||
let rec control map ck s =
|
let rec control map ck s =
|
||||||
match ck with
|
match ck with
|
||||||
|
@ -149,23 +148,23 @@ let translate_var_dec l =
|
||||||
List.map one_var l
|
List.map one_var l
|
||||||
|
|
||||||
let rec translate_extvalue map w =
|
let rec translate_extvalue map w =
|
||||||
let desc = match w.w_desc with
|
let desc = match w.Minils.w_desc with
|
||||||
| Wconst v -> Econst v
|
| Minils.Wconst v -> Econst v
|
||||||
| Wvar x -> Epattern (var_from_name map n)
|
| Minils.Wvar x -> Epattern (var_from_name map x)
|
||||||
| Wfield (w1, f) ->
|
| Minils.Wfield (w1, f) ->
|
||||||
let w1 = translate_extvalue map (assert_1 e_list) in
|
let e = translate_extvalue map w1 in
|
||||||
Epattern (mk_pattern e.e_ty (Lfield (pattern_of_exp e, f)))
|
Epattern (mk_pattern w.Minils.w_ty (Lfield (pattern_of_exp e, f)))
|
||||||
| Wwhen (w1, c, x) ->
|
| Minils.Wwhen (w1, c, x) ->
|
||||||
let e1 = translate_extvalue map w1 in
|
let e1 = translate_extvalue map w1 in
|
||||||
e1.e_desc
|
e1.e_desc
|
||||||
in
|
in
|
||||||
mk_exp e.Minils.e_ty desc
|
mk_exp w.Minils.w_ty desc
|
||||||
|
|
||||||
(* [translate e = c] *)
|
(* [translate e = c] *)
|
||||||
let rec translate map e =
|
let rec translate map e =
|
||||||
let desc = match e.Minils.e_desc with
|
let desc = match e.Minils.e_desc with
|
||||||
| Minils.Eextvalue w ->
|
| 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, _) ->
|
| Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) ->
|
||||||
Eop (op_from_string "=", List.map (translate_extvalue map ) e_list)
|
Eop (op_from_string "=", List.map (translate_extvalue map ) e_list)
|
||||||
| Minils.Eapp ({ Minils.a_op = Minils.Efun n }, 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] *)
|
(* Already treated cases when translating the [eq] *)
|
||||||
| Minils.Eiterator _ | Minils.Emerge _ | Minils.Efby _
|
| Minils.Eiterator _ | Minils.Emerge _ | Minils.Efby _
|
||||||
| Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat
|
| Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat
|
||||||
|Minils.Eupdate|Minils.Eselect_dyn
|
|Minils.Eupdate|Minils.Eselect_dyn
|
||||||
|Minils.Eselect_trunc|Minils.Eselect_slice
|
|Minils.Eselect_trunc|Minils.Eselect_slice
|
||||||
|Minils.Earray_fill|Minils.Efield_update
|
|Minils.Earray_fill|Minils.Efield_update
|
||||||
|Minils.Eifthenelse|Minils.Etuple)}, _, _) ->
|
|Minils.Eifthenelse|Minils.Etuple)}, _, _) ->
|
||||||
internal_error "mls2obc" 5
|
internal_error "mls2obc" 5
|
||||||
in
|
in
|
||||||
mk_exp e.Minils.e_ty desc
|
mk_exp e.Minils.e_ty desc
|
||||||
|
@ -204,7 +203,8 @@ and translate_act map pat
|
||||||
| Minils.Etuplepat p_list,
|
| Minils.Etuplepat p_list,
|
||||||
Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) ->
|
Minils.Eapp ({ Minils.a_op = Minils.Etuple }, act_list, _) ->
|
||||||
List.flatten (List.map2 (translate_act map) p_list 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
|
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)
|
List.flatten (List.map2 (translate_act map) p_list const_list)
|
||||||
(* When Merge *)
|
(* When Merge *)
|
||||||
|
|
|
@ -41,8 +41,8 @@ let write_obc_file p =
|
||||||
let no_conf () = ()
|
let no_conf () = ()
|
||||||
|
|
||||||
let targets = [ "c",(Obc_no_params Cmain.program, no_conf);
|
let targets = [ "c",(Obc_no_params Cmain.program, no_conf);
|
||||||
"java", (Obc_scalar Java_main.program, java_conf);
|
"java", (Obc Java_main.program, java_conf);
|
||||||
"obc", (Obc write_obc_file, no_conf;
|
"obc", (Obc write_obc_file, no_conf);
|
||||||
"obc_np", (Obc_no_params write_obc_file, no_conf);
|
"obc_np", (Obc_no_params write_obc_file, no_conf);
|
||||||
"epo", (Minils write_object_file, no_conf) ]
|
"epo", (Minils write_object_file, no_conf) ]
|
||||||
|
|
||||||
|
|
|
@ -40,7 +40,7 @@ and tdesc =
|
||||||
| Type_struct of structure
|
| Type_struct of structure
|
||||||
|
|
||||||
and extvalue = {
|
and extvalue = {
|
||||||
w_desc : edesc;
|
w_desc : extvalue_desc;
|
||||||
mutable w_ck: ck;
|
mutable w_ck: ck;
|
||||||
w_ty : ty;
|
w_ty : ty;
|
||||||
w_loc : location }
|
w_loc : location }
|
||||||
|
@ -82,7 +82,6 @@ and op =
|
||||||
| Efun of fun_name (** "Stateless" longname <<a_params>> (args) reset r *)
|
| Efun of fun_name (** "Stateless" longname <<a_params>> (args) reset r *)
|
||||||
| Enode of fun_name (** "Stateful" longname <<a_params>> (args) reset r *)
|
| Enode of fun_name (** "Stateful" longname <<a_params>> (args) reset r *)
|
||||||
| Eifthenelse (** if arg1 then arg2 else arg3 *)
|
| Eifthenelse (** if arg1 then arg2 else arg3 *)
|
||||||
| Efield (** arg1.a_param1 *)
|
|
||||||
| Efield_update (** { arg1 with a_param1 = arg2 } *)
|
| Efield_update (** { arg1 with a_param1 = arg2 } *)
|
||||||
| Earray (** [ args ] *)
|
| Earray (** [ args ] *)
|
||||||
| Earray_fill (** [arg1^a_param1] *)
|
| 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_desc = desc; w_ty = ty;
|
||||||
w_ck = clock; w_loc = loc }
|
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_desc = desc; e_ty = ty;
|
||||||
e_ck = clock; e_loc = loc }
|
e_ck = clock; e_loc = loc }
|
||||||
|
|
||||||
|
@ -189,4 +188,4 @@ let mk_program o n t c =
|
||||||
{ p_modname = Module ""; p_format_version = "";
|
{ p_modname = Module ""; p_format_version = "";
|
||||||
p_opened = o; p_nodes = n; p_types = t; p_consts = c }
|
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))
|
||||||
|
|
|
@ -17,22 +17,23 @@ open Minils
|
||||||
either yours either the default version named according to the type. *)
|
either yours either the default version named according to the type. *)
|
||||||
|
|
||||||
type 'a mls_it_funs = {
|
type 'a mls_it_funs = {
|
||||||
app: 'a mls_it_funs -> 'a -> Minils.app -> Minils.app * 'a;
|
app: 'a mls_it_funs -> 'a -> Minils.app -> Minils.app * 'a;
|
||||||
edesc: 'a mls_it_funs -> 'a -> Minils.edesc -> Minils.edesc * 'a;
|
edesc: 'a mls_it_funs -> 'a -> Minils.edesc -> Minils.edesc * 'a;
|
||||||
eq: 'a mls_it_funs -> 'a -> Minils.eq -> Minils.eq * '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;
|
eqs: 'a mls_it_funs -> 'a -> Minils.eq list -> Minils.eq list * 'a;
|
||||||
exp: 'a mls_it_funs -> 'a -> Minils.exp -> Minils.exp * 'a;
|
exp: 'a mls_it_funs -> 'a -> Minils.exp -> Minils.exp * 'a;
|
||||||
pat: 'a mls_it_funs -> 'a -> Minils.pat -> Minils.pat * 'a;
|
extvalue: 'a mls_it_funs -> 'a -> Minils.extvalue -> Minils.extvalue * 'a;
|
||||||
var_dec: 'a mls_it_funs -> 'a -> Minils.var_dec -> Minils.var_dec * 'a;
|
extvalue_desc: 'a mls_it_funs -> 'a -> Minils.extvalue_desc -> Minils.extvalue_desc * 'a;
|
||||||
var_decs: 'a mls_it_funs -> 'a -> Minils.var_dec list
|
pat: 'a mls_it_funs -> 'a -> Minils.pat -> Minils.pat * 'a;
|
||||||
-> Minils.var_dec list * 'a;
|
var_dec: 'a mls_it_funs -> 'a -> Minils.var_dec -> Minils.var_dec * 'a;
|
||||||
contract: 'a mls_it_funs -> 'a -> Minils.contract -> Minils.contract * 'a;
|
var_decs: 'a mls_it_funs -> 'a -> Minils.var_dec list -> Minils.var_dec list * 'a;
|
||||||
node_dec: 'a mls_it_funs -> 'a -> Minils.node_dec -> Minils.node_dec * 'a;
|
contract: 'a mls_it_funs -> 'a -> Minils.contract -> Minils.contract * 'a;
|
||||||
const_dec: 'a mls_it_funs -> 'a -> Minils.const_dec -> Minils.const_dec * 'a;
|
node_dec: 'a mls_it_funs -> 'a -> Minils.node_dec -> Minils.node_dec * 'a;
|
||||||
type_dec: 'a mls_it_funs -> 'a -> Minils.type_dec -> Minils.type_dec * 'a;
|
const_dec: 'a mls_it_funs -> 'a -> Minils.const_dec -> Minils.const_dec * 'a;
|
||||||
tdesc: 'a mls_it_funs -> 'a -> Minils.tdesc -> Minils.tdesc * 'a;
|
type_dec: 'a mls_it_funs -> 'a -> Minils.type_dec -> Minils.type_dec * 'a;
|
||||||
program: 'a mls_it_funs -> 'a -> Minils.program -> Minils.program * 'a;
|
tdesc: 'a mls_it_funs -> 'a -> Minils.tdesc -> Minils.tdesc * 'a;
|
||||||
global_funs:'a Global_mapfold.global_it_funs }
|
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
|
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
|
let ed, acc = edesc_it funs acc e.e_desc in
|
||||||
{ e with e_desc = ed; e_ty = e_ty }, acc
|
{ 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 =
|
and edesc_it funs acc ed =
|
||||||
try funs.edesc funs acc ed
|
try funs.edesc funs acc ed
|
||||||
with Fallback -> edesc funs acc ed
|
with Fallback -> edesc funs acc ed
|
||||||
and edesc funs acc ed = match ed with
|
and edesc funs acc ed = match ed with
|
||||||
| Econst se ->
|
| Eextvalue w ->
|
||||||
let se, acc = static_exp_it funs.global_funs acc se in
|
let w, acc = extvalue_it funs acc w in
|
||||||
Econst se, acc
|
Eextvalue w, acc
|
||||||
| Evar _ -> ed, acc
|
| Efby (se, w) ->
|
||||||
| Efby (se, e) ->
|
|
||||||
let se, acc = optional_wacc (static_exp_it funs.global_funs) acc se in
|
let se, acc = optional_wacc (static_exp_it funs.global_funs) acc se in
|
||||||
let e, acc = exp_it funs acc e in
|
let w, acc = extvalue_it funs acc w in
|
||||||
Efby (se, e), acc
|
Efby (se, w), acc
|
||||||
| Eapp(app, args, reset) ->
|
| Eapp(app, args, reset) ->
|
||||||
let app, acc = app_it funs acc app in
|
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
|
Eapp (app, args, reset), acc
|
||||||
| Ewhen(e, c, x) ->
|
| Emerge(x, c_w_list) ->
|
||||||
let e, acc = exp_it funs acc e in
|
let aux acc (c,w) =
|
||||||
Ewhen(e, c, x), acc
|
let w, acc = extvalue_it funs acc w in
|
||||||
| Emerge(x, c_e_list) ->
|
(c,w), acc in
|
||||||
let aux acc (c,e) =
|
let c_w_list, acc = mapfold aux acc c_w_list in
|
||||||
let e, acc = exp_it funs acc e in
|
Emerge(x, c_w_list), acc
|
||||||
(c,e), acc in
|
| Estruct n_w_list ->
|
||||||
let c_e_list, acc = mapfold aux acc c_e_list in
|
let aux acc (n,w) =
|
||||||
Emerge(x, c_e_list), acc
|
let w, acc = extvalue_it funs acc w in
|
||||||
| Estruct n_e_list ->
|
(n,w), acc in
|
||||||
let aux acc (n,e) =
|
let n_w_list, acc = mapfold aux acc n_w_list in
|
||||||
let e, acc = exp_it funs acc e in
|
Estruct n_w_list, acc
|
||||||
(n,e), acc in
|
|
||||||
let n_e_list, acc = mapfold aux acc n_e_list in
|
|
||||||
Estruct n_e_list, acc
|
|
||||||
| Eiterator (i, app, param, pargs, args, reset) ->
|
| Eiterator (i, app, param, pargs, args, reset) ->
|
||||||
let app, acc = app_it funs acc app in
|
let app, acc = app_it funs acc app in
|
||||||
let param, acc = static_exp_it funs.global_funs acc param in
|
let param, acc = static_exp_it funs.global_funs acc param in
|
||||||
let pargs, acc = mapfold (exp_it funs) acc pargs in
|
let pargs, acc = mapfold (extvalue_it funs) acc pargs in
|
||||||
let args, acc = mapfold (exp_it funs) acc args in
|
let args, acc = mapfold (extvalue_it funs) acc args in
|
||||||
Eiterator (i, app, param, pargs, args, reset), acc
|
Eiterator (i, app, param, pargs, args, reset), acc
|
||||||
|
|
||||||
|
|
||||||
|
@ -183,6 +200,8 @@ let defaults = {
|
||||||
eq = eq;
|
eq = eq;
|
||||||
eqs = eqs;
|
eqs = eqs;
|
||||||
exp = exp;
|
exp = exp;
|
||||||
|
extvalue = extvalue;
|
||||||
|
extvalue_desc = extvalue_desc;
|
||||||
pat = pat;
|
pat = pat;
|
||||||
var_dec = var_dec;
|
var_dec = var_dec;
|
||||||
var_decs = var_decs;
|
var_decs = var_decs;
|
||||||
|
|
|
@ -68,6 +68,9 @@ and print_node_params ff l =
|
||||||
and print_exp_tuple ff l =
|
and print_exp_tuple ff l =
|
||||||
fprintf ff "@[<2>(%a)@]" (print_list_r print_exp """,""") 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 =
|
and print_vd_tuple ff l =
|
||||||
fprintf ff "@[<2>%a@]" (print_list_r print_vd "("";"")") 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
|
fprintf ff "@[<2>%a@]" (print_list print_static_exp "[""][""]") idx
|
||||||
|
|
||||||
and print_dyn_index ff 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 =
|
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 =
|
and print_exp ff e =
|
||||||
if !Compiler_options.full_type_info then
|
if !Compiler_options.full_type_info then
|
||||||
|
@ -89,87 +92,90 @@ and print_exp ff e =
|
||||||
and print_every ff reset =
|
and print_every ff reset =
|
||||||
print_opt (fun ff id -> fprintf ff " every %a" print_ident id) 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
|
and print_exp_desc ff = function
|
||||||
| Econst c -> print_static_exp ff c
|
| Eextvalue w -> print_extvalue ff w
|
||||||
| Evar x -> print_ident ff x
|
| Efby ((Some c), w) -> fprintf ff "@[<2>%a fby@ %a@]" print_static_exp c print_extvalue w
|
||||||
| Efby ((Some c), e) ->
|
| Efby (None, w) -> fprintf ff "pre %a" print_extvalue w
|
||||||
fprintf ff "@[<2>%a fby@ %a@]" print_static_exp c print_exp e
|
|
||||||
| Efby (None, e) -> fprintf ff "pre %a" print_exp e
|
|
||||||
| Eapp (app, args, reset) ->
|
| Eapp (app, args, reset) ->
|
||||||
fprintf ff "@[<2>%a@,%a@]"
|
fprintf ff "@[<2>%a@,%a@]" print_app (app, args) print_every reset
|
||||||
print_app (app, args) print_every reset
|
| Emerge (x, tag_w_list) ->
|
||||||
| Ewhen (e, c, n) ->
|
fprintf ff "@[<2>merge %a@ %a@]" print_ident x print_tag_w_list tag_w_list
|
||||||
fprintf ff "@[<2>(%a@ when %a(%a))@]"
|
| Estruct f_w_list ->
|
||||||
print_exp e print_qualname c print_ident n
|
print_record (print_couple print_qualname print_extvalue """ = """) ff f_w_list
|
||||||
| 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
|
|
||||||
| Eiterator (it, f, param, pargs, args, reset) ->
|
| Eiterator (it, f, param, pargs, args, reset) ->
|
||||||
fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a"
|
fprintf ff "@[<2>(%s (%a)<<%a>>)@,(%a)%a@]%a"
|
||||||
(iterator_to_string it)
|
(iterator_to_string it)
|
||||||
print_app (f, [])
|
print_app (f, [])
|
||||||
print_static_exp param
|
print_static_exp param
|
||||||
print_exp_tuple pargs
|
print_w_tuple pargs
|
||||||
print_exp_tuple args
|
print_w_tuple args
|
||||||
print_every reset
|
print_every reset
|
||||||
|
|
||||||
and print_app ff (app, args) =
|
and print_app ff (app, args) =
|
||||||
match app.a_op with
|
match app.a_op with
|
||||||
| Eequal ->
|
| Eequal ->
|
||||||
let e1, e2 = assert_2 args in
|
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
|
||||||
| Etuple -> print_exp_tuple ff args
|
| Etuple -> print_w_tuple ff args
|
||||||
| Efun f | Enode f ->
|
| Efun f | Enode f ->
|
||||||
fprintf ff "@[%a@,%a@,%a@]"
|
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 ->
|
| Eifthenelse ->
|
||||||
let e1, e2, e3 = assert_3 args in
|
let e1, e2, e3 = assert_3 args in
|
||||||
fprintf ff "@[<hv>if %a@ then %a@ else %a@]"
|
fprintf ff "@[<hv>if %a@ then %a@ else %a@]"
|
||||||
print_exp e1 print_exp e2 print_exp e3
|
print_extvalue e1 print_extvalue e2 print_extvalue 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
|
|
||||||
| Efield_update ->
|
| Efield_update ->
|
||||||
let r,e = assert_2 args in
|
let r,e = assert_2 args in
|
||||||
let f = assert_1 app.a_params in
|
let f = assert_1 app.a_params in
|
||||||
fprintf ff "@[<2>{%a with .%a =@ %a}@]"
|
fprintf ff "@[<2>{%a with .%a =@ %a}@]"
|
||||||
print_exp r print_static_exp f print_exp e
|
print_extvalue r print_static_exp f print_extvalue e
|
||||||
| Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_exp "["";""]") args
|
| Earray -> fprintf ff "@[<2>%a@]" (print_list_r print_extvalue "["";""]") args
|
||||||
| Earray_fill ->
|
| Earray_fill ->
|
||||||
let e = assert_1 args in
|
let e = assert_1 args in
|
||||||
let n = assert_1 app.a_params 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 ->
|
| Eselect ->
|
||||||
let e = assert_1 args in
|
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 ->
|
| Eselect_slice ->
|
||||||
let e = assert_1 args in
|
let e = assert_1 args in
|
||||||
let idx1, idx2 = assert_2 app.a_params in
|
let idx1, idx2 = assert_2 app.a_params in
|
||||||
fprintf ff "%a[%a..%a]"
|
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 ->
|
| Eselect_dyn ->
|
||||||
let r, d, e = assert_2min args in
|
let r, d, e = assert_2min args in
|
||||||
fprintf ff "%a%a default %a"
|
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 ->
|
| Eselect_trunc ->
|
||||||
let e, idx_list = assert_1min args in
|
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 ->
|
| Eupdate ->
|
||||||
let e1, e2, idx = assert_2min args in
|
let e1, e2, idx = assert_2min args in
|
||||||
fprintf ff "@[<2>(%a with %a =@ %a)@]"
|
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 ->
|
| Econcat ->
|
||||||
let e1, e2 = assert_2 args in
|
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 =
|
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 =
|
and print_tag_w_list ff tag_w_list =
|
||||||
fprintf ff "@[%a@]" (print_list print_handler """""") tag_e_list
|
fprintf ff "@[%a@]" (print_list print_handler """""") tag_w_list
|
||||||
|
|
||||||
|
|
||||||
and print_eq ff { eq_lhs = p; eq_rhs = e } =
|
and print_eq ff { eq_lhs = p; eq_rhs = e } =
|
||||||
|
|
|
@ -22,7 +22,9 @@ let err_message ?(exp=void) ?(loc=exp.e_loc) = function
|
||||||
|
|
||||||
let rec static_exp_of_exp e =
|
let rec static_exp_of_exp e =
|
||||||
match e.e_desc with
|
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
|
| _ -> err_message ~exp:e Enot_static_exp
|
||||||
|
|
||||||
(** @return the list of bounds of an array type*)
|
(** @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
|
let is_op = function
|
||||||
| { qual = Pervasives; name = _ } -> true | _ -> false
|
| { qual = Pervasives; name = _ } -> true | _ -> false
|
||||||
|
(*
|
||||||
module Vars =
|
module Vars =
|
||||||
struct
|
struct
|
||||||
let add x acc = if List.mem x acc then acc else x :: acc
|
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 =
|
let read_exp read_funs (is_left, acc_init) e =
|
||||||
(* recursive call *)
|
(* recursive call *)
|
||||||
let _,(_, acc) = Mls_mapfold.exp read_funs (is_left, acc_init) e in
|
let _,(_, acc) = Mls_mapfold.exp read_funs (is_left, acc_init) e in
|
||||||
|
|
||||||
(* special cases *)
|
(* special cases *)
|
||||||
let acc = match e.e_desc with
|
let acc = match e.e_desc with
|
||||||
| Evar x | Emerge(x,_) | Ewhen(_, _, x)
|
| Evar x | Emerge(x,_) | Ewhen(_, _, x)
|
||||||
|
@ -163,3 +166,4 @@ module AllDep = Dep.Make
|
||||||
end)
|
end)
|
||||||
|
|
||||||
let eq_find id = List.find (fun eq -> List.mem id (Vars.def [] eq))
|
let eq_find id = List.find (fun eq -> List.mem id (Vars.def [] eq))
|
||||||
|
*)
|
|
@ -101,9 +101,8 @@ let rec ctype_of_otype oty =
|
||||||
| Types.Tid id when id = Initial.pbool -> Cty_int
|
| Types.Tid id when id = Initial.pbool -> Cty_int
|
||||||
| Tid id -> Cty_id id
|
| Tid id -> Cty_id id
|
||||||
| Tarray(ty, n) -> Cty_arr(int_of_static_exp n, ctype_of_otype ty)
|
| Tarray(ty, n) -> Cty_arr(int_of_static_exp n, ctype_of_otype ty)
|
||||||
| Tmutable t -> ctype_of_otype t
|
|
||||||
| Tprod _ -> assert false
|
| Tprod _ -> assert false
|
||||||
| Tunit -> assert false
|
| Tinvalid -> assert false
|
||||||
|
|
||||||
let cvarlist_of_ovarlist vl =
|
let cvarlist_of_ovarlist vl =
|
||||||
let cvar_of_ovar vd =
|
let cvar_of_ovar vd =
|
||||||
|
|
|
@ -88,7 +88,7 @@ let assert_node_res cd =
|
||||||
statements) needed for a main() function calling [cd]. *)
|
statements) needed for a main() function calling [cd]. *)
|
||||||
let main_def_of_class_def cd =
|
let main_def_of_class_def cd =
|
||||||
let format_for_type ty = match ty with
|
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.pfloat -> "%f"
|
||||||
| Types.Tid id when id = Initial.pint -> "%d"
|
| Types.Tid id when id = Initial.pint -> "%d"
|
||||||
| Types.Tid id when id = Initial.pbool -> "%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,
|
(** Does reading type [ty] need a buffer? When it is the case,
|
||||||
[need_buf_for_ty] also returns the type's name. *)
|
[need_buf_for_ty] also returns the type's name. *)
|
||||||
let need_buf_for_ty ty = match ty with
|
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.pfloat -> None
|
||||||
| Types.Tid id when id = Initial.pint -> None
|
| Types.Tid id when id = Initial.pint -> None
|
||||||
| Types.Tid id when id = Initial.pbool -> None
|
| Types.Tid id when id = Initial.pbool -> None
|
||||||
|
|
|
@ -23,7 +23,6 @@ type ty = Tclass of class_name
|
||||||
| Tint
|
| Tint
|
||||||
| Tfloat
|
| Tfloat
|
||||||
| Tarray of ty * exp
|
| Tarray of ty * exp
|
||||||
| Tref of ty
|
|
||||||
| Tunit
|
| Tunit
|
||||||
|
|
||||||
and classe = { c_protection : protection;
|
and classe = { c_protection : protection;
|
||||||
|
@ -108,7 +107,6 @@ let rec default_value ty = match ty with
|
||||||
| Tint -> Sint 0
|
| Tint -> Sint 0
|
||||||
| Tfloat -> Sfloat 0.0
|
| Tfloat -> Sfloat 0.0
|
||||||
| Tunit -> Evoid
|
| Tunit -> Evoid
|
||||||
| Tref t -> default_value t
|
|
||||||
| Tarray _ -> Enew_array (ty,[])
|
| Tarray _ -> Enew_array (ty,[])
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -42,7 +42,6 @@ let rec _ty size ff t = match t with
|
||||||
| Tclass n -> class_name ff n
|
| Tclass n -> class_name ff n
|
||||||
| Tgeneric (n, ty_l) -> fprintf ff "%a<@[%a@]>" class_name n (print_list_r ty """,""") ty_l
|
| 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
|
| 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"
|
| Tunit -> pp_print_string ff "void"
|
||||||
|
|
||||||
and full_ty ff t = _ty true ff t
|
and full_ty ff t = _ty true ff t
|
||||||
|
|
|
@ -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)
|
| 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
|
and boxed_ty param_env t = match t with
|
||||||
|
| Types.Tprod [] -> Tunit
|
||||||
| Types.Tprod ty_l -> tuple_ty param_env ty_l
|
| 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.pbool -> Tclass (Names.local_qn "Boolean")
|
||||||
| Types.Tid t when t = Initial.pint -> Tclass (Names.local_qn "Integer")
|
| 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 when t = Initial.pfloat -> Tclass (Names.local_qn "Float")
|
||||||
| Types.Tid t -> Tclass (qualname_to_class_name t)
|
| 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.Tarray (t,size) -> Tarray (boxed_ty param_env t, static_exp param_env size)
|
||||||
| Types.Tmutable t -> Tref (boxed_ty param_env t)
|
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type" 1
|
||||||
| Types.Tunit -> Tunit
|
|
||||||
|
|
||||||
and tuple_ty param_env ty_l =
|
and tuple_ty param_env ty_l =
|
||||||
let ln = ty_l |> List.length |> Pervasives.string_of_int in
|
let ln = ty_l |> List.length |> Pervasives.string_of_int in
|
||||||
Tclass (java_pervasive_class ("Tuple"^ln))
|
Tclass (java_pervasive_class ("Tuple"^ln))
|
||||||
|
|
||||||
and ty param_env t :Java.ty = match t with
|
and ty param_env t :Java.ty = match t with
|
||||||
|
| Types.Tprod [] -> Tunit
|
||||||
| Types.Tprod ty_l -> tuple_ty param_env ty_l
|
| Types.Tprod ty_l -> tuple_ty param_env ty_l
|
||||||
| Types.Tid t when t = Initial.pbool -> Tbool
|
| Types.Tid t when t = Initial.pbool -> Tbool
|
||||||
| Types.Tid t when t = Initial.pint -> Tint
|
| Types.Tid t when t = Initial.pint -> Tint
|
||||||
| Types.Tid t when t = Initial.pfloat -> Tfloat
|
| Types.Tid t when t = Initial.pfloat -> Tfloat
|
||||||
| Types.Tid t -> Tclass (qualname_to_class_name t)
|
| Types.Tid t -> Tclass (qualname_to_class_name t)
|
||||||
| Types.Tarray (t,size) -> Tarray (ty param_env t, static_exp param_env size)
|
| Types.Tarray (t,size) -> Tarray (ty param_env t, static_exp param_env size)
|
||||||
| Types.Tmutable t -> Tref (ty param_env t)
|
| Types.Tinvalid -> Misc.internal_error "obc2java invalid type" 1
|
||||||
| Types.Tunit -> Tunit
|
|
||||||
|
|
||||||
and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident }
|
and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_ident }
|
||||||
|
|
||||||
|
|
|
@ -16,6 +16,6 @@ let pp p = if !verbose then Obc_printer.print stdout p
|
||||||
let compile_program p =
|
let compile_program p =
|
||||||
(*Control optimization*)
|
(*Control optimization*)
|
||||||
let p = pass "Control optimization" true Control.program p pp in
|
let p = pass "Control optimization" true Control.program p pp in
|
||||||
(*Scalarize*)
|
(* (*Scalarize*)
|
||||||
let p = pass "Scalarize" !do_scalarize Scalarize.program p pp in
|
let p = pass "Scalarize" !do_scalarize Scalarize.program p pp in *)
|
||||||
p
|
p
|
||||||
|
|
|
@ -49,7 +49,7 @@ let mk_block ?(locals=[]) eq_list =
|
||||||
b_body = eq_list }
|
b_body = eq_list }
|
||||||
|
|
||||||
let mk_ifthenelse cond true_act false_act =
|
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 =
|
let rec var_name x =
|
||||||
match x.pat_desc with
|
match x.pat_desc with
|
||||||
|
@ -73,12 +73,10 @@ let rec vd_find n = function
|
||||||
|
|
||||||
(** Returns the type of a [var_dec list] *)
|
(** Returns the type of a [var_dec list] *)
|
||||||
let vd_list_to_type vd_l = match vd_l with
|
let vd_list_to_type vd_l = match vd_l with
|
||||||
| [] -> Types.Tunit
|
|
||||||
| [vd] -> vd.v_type
|
| [vd] -> vd.v_type
|
||||||
| _ -> Tprod (List.map (fun vd -> vd.v_type) vd_l)
|
| _ -> Tprod (List.map (fun vd -> vd.v_type) vd_l)
|
||||||
|
|
||||||
let pattern_list_to_type p_l = match p_l with
|
let pattern_list_to_type p_l = match p_l with
|
||||||
| [] -> Types.Tunit
|
|
||||||
| [p] -> p.pat_ty
|
| [p] -> p.pat_ty
|
||||||
| _ -> Tprod (List.map (fun p -> p.pat_ty) p_l)
|
| _ -> 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
|
let ei = mk_evar_int i in
|
||||||
Afor (id, down, up, mk_block (body ei))
|
Afor (id, down, up, mk_block (body ei))
|
||||||
|
|
||||||
|
(*
|
||||||
(** Creates the action copying [src] to [dest].*)
|
(** Creates the action copying [src] to [dest].*)
|
||||||
let rec copy_array pass dest src = match dest.l_ty with
|
let rec copy_array pass dest src = match dest.l_ty with
|
||||||
| Tarray (t, n) ->
|
| 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
|
fresh_for pass (mk_static_int 0) n copy
|
||||||
| _ ->
|
| _ ->
|
||||||
Aassgn(dest, Epattern src)
|
Aassgn(dest, Epattern src)
|
||||||
|
*)
|
|
@ -22,7 +22,7 @@ let fresh_for = fresh_for "scalarize"
|
||||||
let act funs () a = match a with
|
let act funs () a = match a with
|
||||||
| Aassgn (p,e) ->
|
| Aassgn (p,e) ->
|
||||||
(match e.e_ty with
|
(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 *)
|
(* a reference (alias) to the array, since we could have a full expression *)
|
||||||
let array_ref = Idents.gen_var "scalarize" "a_ref" in
|
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 (Types.Tmutable p.pat_ty) in
|
||||||
|
|
Loading…
Reference in New Issue