Skip to content
This repository
Newer
Older
100644 200 lines (182 sloc) 7.027 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
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
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* depends *)
19 module Format = BaseFormat
20 module List = BaseList
21
22 (* shorthands *)
23 module Q = QmlAst
24
25 (* -- *)
26
27 type info = { strict : bool ; specialize : (Q.ty * Q.expr) list }
28 type env = info IdentMap.t
29
30
31 let (@) info1 info2 =
32 let strict = info1.strict || info2.strict in
33 let specialize = info1.specialize @ info2.specialize in
34 {
35 strict ;
36 specialize ;
37 }
38
39 let fold_expr f acc env =
40 IdentMap.fold (fun _ info acc ->
41 List.fold_left (fun acc (_,e) -> f acc e) acc info.specialize
42 ) env acc
43
44 let fold_map_expr f acc env =
45 IdentMap.fold_map (
46 fun _ info acc ->
47 let acc, specialize =
48 List.fold_left_map (
49 fun acc (ty,e) ->
50 let acc, e = f acc e in
51 acc, (ty, e)
52 ) acc info.specialize
53 in acc, {
54 info with
55 specialize
56 }
57 ) env acc
58
59 let map_type f env =
60 IdentMap.map
61 (fun info ->
62 let specialize =
63 List.map
64 (fun (ty,e) ->
65 (f ty, e))
66 info.specialize
67 in
68 {
69 info with
70 specialize ;
71 }
72 ) env
73
74 module S =
75 struct
76 type t = Q.annotmap * env
77 let pass = "pass_SimplifyMagic"
78 let pp f _ = Format.pp_print_string f "<dummy>"
79 end
80
81 module R =
82 struct
83 include ObjectFiles.Make(S)
84 let load annotmap (env:env) : S.t =
85 fold_with_name
86 (fun package (annotmap,(env:env)) (annotmap_old,old_env) ->
87 let annotmap_old = QmlRefresh.refresh_annotmap package annotmap_old in
88 let annotmap, old_env = fold_map_expr (QmlRefresh.refresh_expr package ~annotmap_old) annotmap old_env in
89 let old_env = map_type (QmlRefresh.refresh_typevars_from_ty package) old_env in
90 let env = IdentMap.merge (@) env old_env in
91 annotmap, env
92 ) (annotmap,env)
93 let save annotmap env =
94 let small_annotmap = QmlRefresh.restrict_annotmap_fold_expr fold_expr annotmap env in
95 save (small_annotmap,env)
96 end
97
98 let is_monomorphic ty =
99 not (
100 QmlAstWalk.Type.exists
101 (function
102 | Q.TypeVar _ -> true (* FIXME: actually, we should check for rowvars and colvars also *)
103 | _ -> false) ty
104 )
105
106 let build_env env gamma annotmap code =
107 let _, code as result =
108 QmlAstWalk.CodeExpr.fold_map_name_expr
109 (fun (env,annotmap) (ident,expr) ->
110 match expr with
111 | Q.Directive (_, `specialize variant, inner_expr :: l, _) ->
112 (* we refuse polymorphic types for now
113 * or else we might create troubles with ei *)
114 let general_type = QmlAnnotMap.find_ty (Q.QAnnot.expr inner_expr) annotmap in
115 let l =
116 let specialize = List.map (fun e ->
117 let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
118 if not (is_monomorphic ty) then
119 OManager.serror "%a@\n This expression shouldn't contain type variables@."
120 FilePos.pp_pos (Q.Pos.expr e)
121 else (
122 (* should check that ty is an instance of general_type
123 * but since ty is monomorphic, checking the unifiability is equivalent *)
124 if not (QmlMoreTypes.unifiable ~gamma general_type ty) then
125 OManager.serror "%a@\n This expression's type should be an instance of the generic expression's type.@."
126 FilePos.pp_pos (Q.Pos.expr e)
127 );
128 ty, e) l in
129 let strict = variant = `strict in
130 {
131 strict ;
132 specialize ;
133 }
134 in
135 let env = IdentMap.update_default ident ((@) l) l env in
136 let tsc = QmlAnnotMap.find_tsc_opt (Q.QAnnot.expr expr) annotmap in
137 let annotmap = QmlAnnotMap.add_tsc_opt (Q.QAnnot.expr inner_expr) tsc annotmap in
138 (env,annotmap), (ident, inner_expr)
139 | _ ->
140 (env,annotmap), (ident, expr))
141 (env,annotmap) code in
142 QmlAstWalk.CodeExpr.iter
143 (QmlAstWalk.Expr.iter
144 (function
145 | Q.Directive (label, `specialize _, _, _) ->
146 OManager.serror "%a@\n Illegal @@specialize: it can only be the topmost directive on a toplevel binding.@."
147 FilePos.pp_pos (Annot.pos label)
148 | _ -> ()
149 )
150 ) code;
151 result
152
153 let rewrite_expr env gamma annotmap code =
154 let rec aux tra annotmap e =
155 match e with
156 | Q.Ident (label, i) ->
157 let annot = Annot.annot label in
158 (try
159 let info = IdentMap.find i env in
160 let choices = info.specialize in
161 let ty = QmlAnnotMap.find_ty annot annotmap in
162 try let _, expr = List.find (fun (ty',_) -> QmlMoreTypes.equal_ty ~gamma ty ty') choices in
163 let annotmap, expr = QmlAstCons.TypedExpr.copy annotmap expr in
164 aux tra annotmap expr
165 with Not_found ->
166 let fail () =
167 QmlPrint.pp#reset_typevars;
168 let context = QmlError.Context.label label in
169 QmlError.error context (
170 "Failed specialization on %s with type %a@\n"^^
171 "@[<2>@{<bright>Hint@}:@\n"^^
172 "Add a type annotation for a specialization in one of the following types:@\n"^^
173 "%a"^^
174 "@]"
175 )
176 (Ident.original_name i) QmlPrint.pp#ty ty
177 (Format.pp_list "@\n" (Format.pp_fst QmlPrint.pp#ty)) choices
178 in
179 if info.strict
180 then
181 fail ()
182 else (
183 #<If:SIMPLIFYMAGIC_FAILURES>
184 fail ()
185 #<End> ;
186 ) ;
187 tra annotmap e
188 with Not_found -> tra annotmap e)
189 | _ -> tra annotmap e in
190 QmlAstWalk.Expr.traverse_foldmap aux annotmap code
191
192 let process_code ?(specialized_env=IdentMap.empty) gamma annotmap code =
193 let (env,annotmap), code = build_env specialized_env gamma annotmap code in
194 R.save annotmap env;
195 #<If:SIMPLIFYMAGIC_DISABLE>
196 annotmap, code
197 #<Else>
198 let annotmap, env = R.load annotmap env in
199 QmlAstWalk.CodeExpr.fold_map (rewrite_expr env gamma) annotmap code
200 #<End>
Something went wrong with that request. Please try again.