Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 299 lines (263 sloc) 12.22 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
5bb0f1a Frederic Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
4 This file is part of Opa.
fccc685 Initial open-source release
MLstate authored
5
5bb0f1a Frederic Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
6 Opa is free software: you can redistribute it and/or modify it under the
fccc685 Initial open-source release
MLstate authored
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
5bb0f1a Frederic Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
10 Opa is distributed in the hope that it will be useful, but WITHOUT ANY
fccc685 Initial open-source release
MLstate authored
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
5bb0f1a Frederic Ye [cleanup] compiler: typo on Opa
Aqua-Ye authored
16 along with Opa. If not, see <http://www.gnu.org/licenses/>.
fccc685 Initial open-source release
MLstate authored
17 *)
18 (*
19 Author: 2011, François Pessaux <francois.pessaux@mlstate.com>
20 *)
21
22 (**
23 Strongly mapped on hmx_Compare.ml of the old HMX typechecker.
24 This module implements comparison on QML types with the semantics that
25 old HMX typechecker had when it first transformed QML types into HMX types
26 then compared the HMX types.
27 The idea is to remove the bridge between QML and HMX primitives since HMX
28 is not used anymore. However, QML still used some parts of HMX functions
29 for various things. That's the reason why this module exists.
30 *)
31
32 (* depends *)
33 module List = BaseList
34
35 (* shorthands *)
36 module Q = QmlAst
37
38
39
40 module TyPairSet : (BaseSetSig.S with type elt = QmlAst.ty * QmlAst.ty) =
41 BaseSet.Make (
42 struct
43 type t = QmlAst.ty * QmlAst.ty
44 let compare = Pervasives.compare
45 end
46 )
47
48
49
50 (**
51 sort the list of type variables [bvs] bounds in a TypeForall
52 according to the apparition order in the quantified type [t]
53 *)
54 (* TODO : extend to row and column variables *)
55 let sort_bound_vars env bvs t =
56 let rec aux memo (sbvs, bvs) t =
57 match t with
58 | Q.TypeSumSugar _ ->
38cc372 fpessaux [cleanup] QML typer: Just typos & spelling by the way.
fpessaux authored
59 (* They should have all disappeared. *)
fccc685 Initial open-source release
MLstate authored
60 assert false
61 | Q.TypeConst _ -> (sbvs, bvs)
62 | Q.TypeVar v ->
63 if List.mem v bvs then ((v :: sbvs), (List.remove_first v bvs))
64 else (sbvs, bvs)
65 | Q.TypeArrow (lt, u) ->
66 aux memo (List.fold_left (aux memo) (sbvs, bvs) lt) u
67 | Q.TypeRecord (Q.TyRow (fields, _)) -> aux_fields memo (sbvs, bvs) fields
68 | Q.TypeSum (Q.TyCol (l_fields, _)) ->
69 List.fold_left (aux_fields memo) (sbvs, bvs) l_fields
70 | Q.TypeName (lt, tn) ->
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
71 let (tsc, _) =
fccc685 Initial open-source release
MLstate authored
72 QmlTypes.Env.TypeIdent.find ~visibility_applies: true tn env in
73 let acc =
74 if List.mem t memo then (sbvs, bvs)
75 else
76 let t' = QmlTypes.Scheme.specialize ~typeident: tn ~ty: lt tsc in
77 aux (t :: memo) (sbvs, bvs) t' in
78 (* explore phantom types, because they don't appear in the body *)
79 let (vars, _, _) = QmlGenericScheme.export_unsafe tsc in
80 let (typevars, _, _) = QmlTypeVars.FreeVars.export_as_lists vars in
81 let count_t_c_freevars t _c = QmlTypes.freevars_of_ty t in
82 let phantomvars =
83 QmlGenericScheme.phantomvars_with_cache count_t_c_freevars tsc in
84 let fold_fun acc v t =
85 if QmlTypeVars.FreeVars.mem_typevar v phantomvars then aux memo acc t
86 else acc in
87 List.fold_left2 fold_fun acc typevars lt
88 | Q.TypeAbstract -> (sbvs, bvs)
89 | Q.TypeForall (_, _, _, t) -> aux memo (sbvs, bvs) t
90
91 and aux_fields memo (sbvs, bvs) fields =
92 let lt = List.map snd fields in
93 List.fold_left (aux memo) (sbvs, bvs) lt in
94
95 (* Note that it is legal to have variable not "seen", i.e. variable remaining
96 in [bvs] and not sent to [sbvs] after sorting because when a type name is
97 defined as an abstract type, since this latter doesn't have parameter,
98 parameters of the type name do not appear in the instantiation hence are
99 not "seen". As a result, they in effect are not removed from the list [bvs]
100 and not added in the list [sbvs]. *)
101 let (sbvs, _) = aux [] ([], bvs) t in
102 List.rev sbvs
103
104
105
106 let sort_row_fields fields =
107 List.sort (fun (n1, _) (n2, _) -> String.compare n1 n2) fields
108
109
110
111 let sort_col_cases (Q.TyCol (cases, ending)) =
112 (* First, for each case, sort the fields of the row forming the case. *)
113 let cases' = List.map sort_row_fields cases in
114 (* Now, sort each case according to the fields it has. *)
115 let cases'' =
116 List.sort
117 (fun case1 case2 ->
118 List.make_compare
119 (fun (n1, _) (n2, _) -> String.compare n1 n2) case1 case2)
120 cases' in
121 QmlAst.TyCol (cases'', ending)
122
123
124
125 let rec test_tys_eq env ?(bound_vars=[]) memo t1 t2 =
126 let call_aux ?(bound_vars=bound_vars) = test_tys_eq env ~bound_vars memo in
127 let is_bound v = List.mem v bound_vars in
128 if t1 == t2 then true (* speedup *) else
129 match t1, t2 with
130 | ((Q.TypeConst c), (Q.TypeConst d)) -> c = d
131 | ((Q.TypeVar v1), (Q.TypeVar v2)) when is_bound v1 && not (is_bound v2) ->
132 false
133 | ((Q.TypeVar v1), (Q.TypeVar v2)) when not (is_bound v1) && is_bound v2 ->
134 false
135 | ((Q.TypeVar v1), (Q.TypeVar v2)) -> v1 = v2
136 | ((Q.TypeArrow (lt, t)), (Q.TypeArrow (lu, u))) ->
137 ((List.length lt) = (List.length lu)) &&
138 (List.for_all2 (call_aux ~bound_vars) lt lu) &&
139 (call_aux ~bound_vars t u)
140 | ((Q.TypeSum ts), (Q.TypeSum us)) -> cmp_col env memo ts us
141 | ((Q.TypeRecord rx), (Q.TypeRecord ry)) -> cmp_row env memo rx ry
142 | (Q.TypeRecord (Q.TyRow (tfs, trv))), (Q.TypeSum (Q.TyCol (ufs, ucv))) -> (
143 match trv with
144 | Some _ -> false
145 | None ->
146 match ucv with
147 | Some _ -> false
148 | None ->
149 (* No row/column variables -> compare fields *)
150 (match ufs with
151 | [ one ] ->
152 (* To be "equal", the sum must have only 1 case. *)
153 sort_and_cmp_fields env memo tfs one
154 | _ -> false)
155 )
156 | ((Q.TypeSum _), (Q.TypeRecord _)) -> call_aux ~bound_vars t2 t1
157 | ((Q.TypeName (ts, tn)), (Q.TypeName (us, un))) ->
158 if TyPairSet.mem (t1, t2) memo then true (* already seen, assumed equal *)
159 else (
160 let memo = TyPairSet.add (t1, t2) (TyPairSet.add (t2, t1) memo) in
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
161 let (tn, (te, _)) =
fccc685 Initial open-source release
MLstate authored
162 QmlTypes.Env.TypeIdent.findi ~visibility_applies: true tn env in
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
163 let (un, (ue, _)) =
fccc685 Initial open-source release
MLstate authored
164 QmlTypes.Env.TypeIdent.findi ~visibility_applies: true un env in
30e5289 fpessaux [cleanup] QML types comparison: Code sharing and de-obfuscat-ion.
fpessaux authored
165 (* First, perform a test ensuring that both types have the same names
166 and the same arguments (by induction, they hence will be the
167 same). *)
168 let are_equal_by_name =
fccc685 Initial open-source release
MLstate authored
169 (QmlAst.TypeIdent.equal tn un) &&
30e5289 fpessaux [cleanup] QML types comparison: Code sharing and de-obfuscat-ion.
fpessaux authored
170 ((List.length ts) = (List.length us)) &&
171 (List.for_all2 (call_aux ~bound_vars) ts us) in
172 (* Types are equal just by their name and inductively by their
173 argument, then we are done, test is true. *)
174 if are_equal_by_name then true
fccc685 Initial open-source release
MLstate authored
175 else (
30e5289 fpessaux [cleanup] QML types comparison: Code sharing and de-obfuscat-ion.
fpessaux authored
176 (* Ok, we are in the case where the 2 types are not equal by names.
177 This means that they have different name and/or different
ef73302 fpessaux [cleanup] QML types: Need of tags on TypeIdent finally removed for this ...
fpessaux authored
178 arguments. *)
179 let t = QmlTypes.Scheme.specialize ~typeident: tn ~ty: ts te in
180 let u = QmlTypes.Scheme.specialize ~typeident: un ~ty: us ue in
181 (* If these types are abstract, then they have no more internal
182 representation (i.e. they are not abbreviations that could point on
183 a same representation, and they don't have any own structure) and
184 hence they are *different*. *)
185 if (t = QmlAst.TypeAbstract) && (u = QmlAst.TypeAbstract) then false
186 else test_tys_eq env ~bound_vars memo t u
fccc685 Initial open-source release
MLstate authored
187 )
188 )
189 | ((Q.TypeForall _), _) | (_, (Q.TypeForall _)) ->
190 (* let env_vars = env.Hmx_env.freevars_of_idents in *)
191 let t = (* generalize_in_type env_vars *) t1 in
192 let u = (* generalize_in_type env_vars *) t2 in
193 let res = (
194 match (t, u) with
195 | Q.TypeForall (t_bvs, t_row_vars, t_col_vars, t),
196 Q.TypeForall (u_bvs, _, _, u) ->
38cc372 fpessaux [cleanup] QML typer: Just typos & spelling by the way.
fpessaux authored
197 (* TODO : comparison is not correct !!! *)
fccc685 Initial open-source release
MLstate authored
198 (* quantification over row and column variables is not handled *)
199 let t_bvs = sort_bound_vars env t_bvs t in
200 let u_bvs = sort_bound_vars env u_bvs u in
201 if (List.length t_bvs) <> (List.length u_bvs) then false
202 else (
203 (* At this point, we are sure that the lists of quantified vars
204 are the same length. So we can safely transform the type t
205 into a pseudo scheme, call QmlTypes.instantiate on it with
206 a fake type ident since lists of quantified vars being the
207 same length, we won't get an error, so the fake ident won't
38cc372 fpessaux [cleanup] QML typer: Just typos & spelling by the way.
fpessaux authored
208 re-spring. *)
fccc685 Initial open-source release
MLstate authored
209 let fake_ident =
210 QmlAst.TypeIdent.of_string "__icmpty_broken_if_seen " in
211 let fake_quantif =
212 QmlTypeVars.FreeVars.add_list
213 (t_bvs, t_row_vars, t_col_vars) QmlTypeVars.FreeVars.empty in
214 let fake_sch = QmlGenericScheme.import fake_quantif t () in
215 let fake_ml_vars = List.map (fun v -> QmlAst.TypeVar v) t_bvs in
216 let fake_row_vars =
217 List.map (fun v -> QmlAst.TyRow ([], (Some v))) t_row_vars in
218 (* Instantiate the pseudo scheme built from the body of t.
219 Instantiation is done by replacing its variables by those of
220 u. *)
221 let t =
222 QmlTypes.Scheme.specialize
223 ~typeident: fake_ident ~ty: fake_ml_vars
224 ~ty_row: fake_row_vars fake_sch in
225 call_aux ~bound_vars: (t_bvs @ bound_vars) t u
226 )
227 | ((Q.TypeForall _), _) | (_, (Q.TypeForall _)) -> false
228 | _ -> assert false (* at least one of them should be a TypeForall *)
229 ) in
230 res
231 | ((Q.TypeName (ts, tn)), u) ->
232 (* beware of type 'a nil = {nil:unit}, then int nil = float nil *)
233 if TyPairSet.mem (t1, t2) memo then false
234 else (
235 let memo = TyPairSet.add (t1, t2) memo in
b12589b fpessaux [feature] Typer: Height of type abbreviation to balance unwinding during...
fpessaux authored
236 let (tn, (te, _)) =
fccc685 Initial open-source release
MLstate authored
237 QmlTypes.Env.TypeIdent.findi ~visibility_applies: true tn env in
ef73302 fpessaux [cleanup] QML types: Need of tags on TypeIdent finally removed for this ...
fpessaux authored
238 let t = QmlTypes.Scheme.specialize ~typeident: tn ~ty: ts te in
239 if t = QmlAst.TypeAbstract then false
240 else test_tys_eq env memo t u
fccc685 Initial open-source release
MLstate authored
241 )
242 | (_, (Q.TypeName (_, _))) -> call_aux ~bound_vars t2 t1
243 | (Q.TypeAbstract, _) | (_, Q.TypeAbstract) -> false
244 | (_, _) ->
245 (* Different constructors or not matching extern abstract type:
246 fall back on Pervasives' comparison *)
247 t1 = t2
248
249
250
251 and sort_and_cmp_fields env memo tfs ufs =
252 let cmp_field (tfn, tft) (ufn, uft) =
253 (tfn = ufn) && (test_tys_eq env memo tft uft) in
254 (* First, compare lists lengths. *)
255 if (List.length tfs) <> (List.length ufs) then false
256 else (
257 (* Sort the fields by name. *)
258 let tfs' = sort_row_fields tfs in
259 let ufs' = sort_row_fields ufs in
260 List.for_all2 cmp_field tfs' ufs'
261 )
262
263
264
265 (* Fields will be sorted by name by calling [sort_and_cmp_fields]. No need
266 to sort them in this function. *)
267 and cmp_row env memo (Q.TyRow (tfs, tv)) (Q.TyRow (ufs, uv)) =
268 let row_var_eq =
269 (match (tv, uv) with
270 | (None, None) -> true
271 | (None, (Some _)) | ((Some _), None) -> false
272 | ((Some v1), (Some v2)) -> (QmlAst.RowVar.equal v1 v2)) in
273 row_var_eq && (sort_and_cmp_fields env memo tfs ufs)
274
275
276
277 (* Since to sort cases, we need to sort fields of each row forming a case,
278 to avoid sorting several times, we don't use [cmp_row] and
279 [sort_and_cmp_fields] and directly sort the whole column in one shot here. *)
280 and cmp_col env memo (Q.TyCol (_tfs, tv) as tcol) (Q.TyCol (_ufs, uv) as ucol) =
281 let col_var_eq =
282 (match (tv, uv) with
283 | (None, None) -> true
284 | (None, (Some _)) | ((Some _), None) -> false
285 | ((Some v1), (Some v2)) -> QmlAst.ColVar.equal v1 v2) in
286 if not col_var_eq then false
287 else (
288 (* Sort the cases. *)
289 let tcol = sort_col_cases tcol in
290 let ucol = sort_col_cases ucol in
291 let ts = Q.column_to_records tcol in
292 let us = Q.column_to_records ucol in
293 ((List.length ts) = (List.length us)) &&
294 (List.for_all2 (test_tys_eq env memo) ts us)
295 )
296
297
298 let equal_ty env t u = test_tys_eq env TyPairSet.empty t u
Something went wrong with that request. Please try again.