Fix for memalloc

Take the simplified versions of types (i.e. 
with constants instantiated) to check the 
equality of types
This commit is contained in:
Cédric Pasteur 2012-09-14 16:08:26 +02:00
parent 96e233b64c
commit 36bfa81b17
3 changed files with 15 additions and 11 deletions

View file

@ -186,6 +186,11 @@ let simplify env se =
try eval_core true env se
with exn -> message exn
let rec simplify_type env ty = match ty with
| Tarray(ty, e) -> Tarray(simplify_type env ty, simplify env e)
| Tprod l -> Tprod (List.map (simplify_type env) l)
| t -> t
(** [eval env e] does the same as [simplify]
but if it returns, there are no variables nor op left.
@raise [Errors.Error] when it cannot fully evaluate. *)

View file

@ -299,11 +299,6 @@ let build_subst names values =
List.fold_left2 (fun m n v -> QualEnv.add n v m)
QualEnv.empty 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)
| t -> t
let add_distinct_env id vd env =
if Env.mem id env then
error (Ealready_defined(name id))
@ -640,8 +635,8 @@ let rec typing cenv h e =
List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in
let m = build_subst node_params params in
let expected_ty_list =
List.map (subst_type_vars m) expected_ty_list in
let result_ty_list = List.map (subst_type_vars m) result_ty_list in
List.map (simplify_type m) expected_ty_list in
let result_ty_list = List.map (simplify_type m) result_ty_list in
let typed_n_list = List.map (expect_static_exp cenv (Tid Initial.pint)) n_list in
(*typing of partial application*)
let p_ty_list, expected_ty_list =
@ -776,9 +771,9 @@ and typing_app cenv h app e_list =
let op, expected_ty_list, result_ty_list = kind f ty_desc in
let node_params = List.map (fun { p_name = n } -> local_qn n) ty_desc.node_params in
let m = build_subst node_params app.a_params in
let expected_ty_list = List.map (subst_type_vars m) expected_ty_list in
let expected_ty_list = List.map (simplify_type m) expected_ty_list in
let typed_e_list = typing_args cenv h expected_ty_list e_list in
let result_ty_list = List.map (subst_type_vars m) result_ty_list in
let result_ty_list = List.map (simplify_type m) result_ty_list in
(* Type static parameters and generate constraints *)
let typed_params = typing_node_params cenv ty_desc.node_params app.a_params in
let constrs = List.map (simplify m) ty_desc.node_param_constraints in

View file

@ -132,7 +132,7 @@ module InterfRead = struct
in
List.fold_left tr_one [] wl
let read_extvalue funs acc w =
let read_extvalue _ acc w =
(* recursive call *)
(*let _, acc = Mls_mapfold.extvalue funs acc w in*)
let acc =
@ -386,10 +386,14 @@ let should_interfere = Misc.memoize_couple should_interfere
variable declaration list vds. It just creates one graph per type
and one node per declaration. *)
let init_interference_graph () =
let add_tyenv env iv =
let ty = Static.simplify_type Names.QualEnv.empty (World.ivar_type iv) in
TyEnv.add_element ty (mk_node iv) env
in
(** Adds a node for the variable and all fields of a variable. *)
let rec add_ivar env iv ty =
let ivars = all_ivars [] iv None ty in
List.fold_left (fun env iv -> TyEnv.add_element (World.ivar_type iv) (mk_node iv) env) env ivars
List.fold_left add_tyenv env ivars
in
let env = Env.fold
(fun _ vd env -> add_ivar env (Ivar vd.v_ident) vd.v_type) !World.vds TyEnv.empty in