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:
parent
96e233b64c
commit
36bfa81b17
3 changed files with 15 additions and 11 deletions
|
@ -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. *)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue