Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

[feature] value restriction: limit value restriction to variable type…

… that are related to a mutable value

mutable values includes external type and closure type
  • Loading branch information...
commit f420408371e90a923a72aeaf0d0abc195fed4972 1 parent a7a6ca6
Rudy Sicard OpaOnWindowsNow authored
31 compiler/libqmlcompil/qmlAstUtils.ml
View
@@ -153,10 +153,41 @@ let is_expansive_strict =
| e -> tra e
)
+(* only elements taking part in the expression type counts *)
+let expansive_nodes_related_to_type ?(strict=false) =
+ QmlAstWalk.Expr.traverse_fold
+ (fun tra acc -> function
+ | Q.Const _
+ | Q.Ident _
+ | Q.Lambda _
+ | Q.Bypass _ -> acc
+
+ | Q.Directive (_, `llarray, [], _) when not(strict) ->
+ acc (* the empty array is the only one that is not expansive
+ * because it is not mutable *)
+
+ | Q.Directive (_, #stop_expansiveness, _, _) when not(strict) ->
+ acc
+
+ | Q.Directive (_, #non_expansive, _exprs, _) as d when not(strict) ->
+ tra acc d
+
+ | Q.Directive (_, #strictly_non_expansive, _exprs, _) as d
+ -> tra acc d
+
+ | (Q.Directive(a, _, _, _)
+ | Q.Apply(a, _, _)) as e ->
+ tra (a::acc) e
+
+ | e -> tra acc e) []
let is_expansive_with_options = function
| `disabled -> (fun _ -> false)
| `normal -> is_expansive
| `strict -> is_expansive_strict
+let expansive_nodes_related_to_type_with_options = function
+ | `disabled -> (fun _ -> [])
+ | `normal -> expansive_nodes_related_to_type ~strict:false
+ | `strict -> expansive_nodes_related_to_type ~strict:true
module App =
struct
1  compiler/libqmlcompil/qmlAstUtils.mli
View
@@ -114,6 +114,7 @@ val collect_annot : Annot.t -> QmlAst.expr -> QmlAst.expr list
val is_expansive : QmlAst.expr -> bool
val is_expansive_strict : QmlAst.expr -> bool
val is_expansive_with_options : [`disabled|`normal|`strict] -> (QmlAst.expr -> bool)
+val expansive_nodes_related_to_type_with_options : [`disabled|`normal|`strict] -> (QmlAst.expr -> Annot.label list)
module App : sig
(**
29 compiler/libqmlcompil/qmlMakeTyper.ml
View
@@ -423,10 +423,35 @@ struct
e.g. due to value restriction, then use [generalize]
instead of [quantify] *)
let sch =
+ (* do the dumb check (for efficiency) *)
+ (* collect id of expansives elements that influence the type of the expression *)
+ (* collect type var of expansiv elements *)
+ (* intersect with var of main type *)
+ (* if intersection is not empty say something *)
let is_expansive = QmlAstUtils.is_expansive_with_options options.QT.value_restriction in
- if not (QT.FreeVars.is_type_empty (QT.freevars_of_ty ty)) && is_expansive exp
- then (
+ let mutable_vars ty =
+ List.fold_left (fun acc ty -> QT.FreeVars.union (QT.freevars_of_ty ty) acc) QT.FreeVars.empty
+ (QmlTypesUtils.Inspect.get_type_potentially_in_non_pure_type gamma ty)
+ in
+ let expansive_nodes_interacts set1 exp =
+ let expansive_nodes = QmlAstUtils.expansive_nodes_related_to_type_with_options options.QT.value_restriction exp in
+ List.fold_left (fun ((set_acc,l_acc) as acc) label->
+ let ty = QmlAnnotMap.find_ty (Annot.annot label) annotmap in
+ let set2 = mutable_vars ty in
+ if QmlTypeVars.FreeVars.is_empty set2 then acc
+ else
+ let inter = QmlTypeVars.FreeVars.inter set1 set2 in
+ if QmlTypeVars.FreeVars.is_empty inter then acc
+ else (QmlTypeVars.FreeVars.union set_acc inter,label::l_acc)
+ ) (QmlTypeVars.FreeVars.empty,[]) expansive_nodes
+ in
+ if is_expansive exp then (
+ let mutable_freevars_ty = mutable_vars ty in
+ if not (QT.FreeVars.is_type_empty mutable_freevars_ty) then
+ let (freevars_expansive,labels) = expansive_nodes_interacts mutable_freevars_ty exp in
+ if not (QT.FreeVars.is_type_empty freevars_expansive) then
let context = QmlError.Context.annoted_expr annotmap exp in
+ let context = QmlError.Context.merge context (List.map QmlError.Context.label labels) in
QmlError.serror context
"Value restriction error@\n@[<2>This expression is not generalizable but it has type@ %a .@]"
QmlPrint.pp_value_restriction#ty_new_scope ty
23 compiler/libqmlcompil/qmlTypesUtils.ml
View
@@ -255,6 +255,29 @@ struct
match follow_alias_noopt_private ~until:"ordered_map" gamma ty with
| Q.TypeName ([_; dty; _], _) -> dty
| _ -> raise Not_found
+
+ let get_type_potentially_in_non_pure_type gamma ty=
+ let rec aux memo ty acc =
+ QmlAstWalk.Type.traverse_fold (fun tra acc ty ->
+ match ty with
+ | Q.TypeArrow (args, res) ->
+ (* TODO see if return type really need to be here *)
+ (res::args) @ acc (* potentially hidden by partial application *)
+ | Q.TypeName (params, _) ->
+ let ty = get_deeper_typename gamma ty in
+ (match follow_alias gamma ty with
+ | Some Q.TypeAbstract
+ | None -> params@acc (* no type name implementation => potentially not pure *)
+ | Some implem -> if List.mem ty memo then acc else aux (ty::memo) implem acc
+ )
+ | Q.TypeAbstract -> assert false
+ | Q.TypeForall (q1, q2, q3, body) -> (*ty::acc*) (* TODO do not ignore for all quantification *)
+ let acc1 = aux memo body [] in
+ (List.map (fun ty -> Q.TypeForall(q1,q2,q3,ty)) acc1)@acc
+ | ty -> tra acc ty (* recurse in type components *)
+ ) acc ty
+ in
+ aux [] ty []
end
module TypeArrow =
3  compiler/libqmlcompil/qmlTypesUtils.mli
View
@@ -91,6 +91,9 @@ sig
(** Returns the type of data of the [ty] map. If the given [ty] is not a type
of map (or an alias) throws [Not_found].*)
val get_data_type_of_map : QmlTypes.gamma -> QmlAst.ty -> QmlAst.ty
+
+ (** Returns all types inside the given type that could be in a mutable container *)
+ val get_type_potentially_in_non_pure_type : QmlTypes.gamma -> QmlAst.ty -> QmlAst.ty list
end
(** Utils for arrow types *)
Please sign in to comment.
Something went wrong with that request. Please try again.