Home My Page Projects Code Snippets Project Openings diderot
Summary Activity Tracker Tasks SCM

SCM Repository

[diderot] Annotation of /branches/vis15/src/compiler/tree-ir/check-tree.sml
ViewVC logotype

Annotation of /branches/vis15/src/compiler/tree-ir/check-tree.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3754 - (view) (download)

1 : jhr 3754 (* check-tree.sml
2 :     *
3 :     * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     *
5 :     * COPYRIGHT (c) 2016 The University of Chicago
6 :     * All rights reserved.
7 :     *
8 :     * TODO: check global and state variable consistency
9 :     *)
10 :    
11 :     structure CheckTree : sig
12 :    
13 :     val check : string * TreeIR.program -> bool
14 :    
15 :     end = struct
16 :    
17 :     structure IR = TreeIR
18 :     structure Op = TreeOps
19 :     structure GVar = IR.GlobalVar
20 :     structure SVar = IR.StateVar
21 :     structure Var = IR.Var
22 :     structure VSet = Var.Set
23 :     structure Ty = IR.Ty
24 :    
25 :     datatype token
26 :     = NL | S of string | A of Atom.atom | V of IR.var
27 :     | TY of Ty.ty | TYS of Ty.ty list
28 :    
29 :     fun error errBuf toks = let
30 :     fun tok2str NL = "\n ** "
31 :     | tok2str (S s) = s
32 :     | tok2str (A s) = Atom.toString s
33 :     | tok2str (V x) = Var.toString x
34 :     | tok2str (TY ty) = Ty.toString ty
35 :     | tok2str (TYS []) = "()"
36 :     | tok2str (TYS[ty]) = Ty.toString ty
37 :     | tok2str (TYS tys) = String.concat[
38 :     "(", String.concatWith " * " (List.map Ty.toString tys), ")"
39 :     ]
40 :     in
41 :     errBuf := concat ("**** Error: " :: List.map tok2str toks)
42 :     :: !errBuf
43 :     end
44 :    
45 :     fun check (phase, prog) = let
46 :     val IR.Program{
47 :     props, consts, inputs, constInit, globals, globalInit,
48 :     strand, create, update
49 :     } = prog
50 :     val errBuf = ref []
51 :     val errFn = error errBuf
52 :     fun final () = (case !errBuf
53 :     of [] => false
54 :     | errs => (
55 :     Log.msg ["********** IR Errors detected after ", phase, " **********\n"];
56 :     List.app (fn msg => Log.msg [msg, "\n"]) (List.rev errs);
57 :     true)
58 :     (* end case *))
59 :     (* check a variable use *)
60 :     fun checkVar (bvs, x) = if VSet.member(bvs, x)
61 :     then ()
62 :     else errFn [S "variable ", V x, S " is not bound"]
63 :     fun chkBlock (bvs, IR.Block{locals, body}) = let
64 :     fun chkExp (bvs, e) = let
65 :     fun chk e = (case e
66 :     of IR.E_Global gv => GVar.ty gv
67 :     | IR.E_State sv => SVar.ty sv
68 :     | IR.E_Var x => Var.ty x
69 :     | IR.E_Lit(Literal.Int _) => Ty.IntTy
70 :     | IR.E_Lit(Literal.Real _) => Ty.realTy
71 :     | IR.E_Lit(Literal.String _) => Ty.StringTy
72 :     | IR.E_Lit(Literal.Bool _) => Ty.BoolTy
73 :     | IR.E_Op(rator, args) => let
74 :     val (resTy, paramTys) = Op.sigOf rator
75 :     val argTys = List.map chk args
76 :     in
77 :     if ListPair.allEq Ty.same (paramTys, argTys)
78 :     then ()
79 :     else errFn [
80 :     S "argument type mismatch in application of ",
81 :     S(Op.toString rator),
82 :     NL, S "expected: ", TYS paramTys,
83 :     NL, S "found: ", TYS argTys
84 :     ];
85 :     resTy
86 :     end
87 :     | IR.E_Cons([], ty) => (
88 :     errFn [S "empty cons"];
89 :     ty)
90 :     | IR.E_Cons(es, consTy as Ty.TensorTy(d, ty)) => (
91 :     if (length es <> d)
92 :     then errFn [
93 :     S "cons has incorrect number of elements",
94 :     NL, S " expected: ", S(Int.toString d),
95 :     NL, S " found: ", S(Int.toString(length es))
96 :     ]
97 :     else ();
98 :     chkElems ("cons", ty, es);
99 :     consTy)
100 :     | IR.E_Seq([], ty as Ty.SeqTy(_, SOME 0)) => ty
101 :     | IR.E_Seq([], ty as Ty.SeqTy(_, SOME n)) => (
102 :     errFn [S "empty sequence, but expected ", TY ty];
103 :     ty)
104 :     | IR.E_Seq(es, seqTy as Ty.SeqTy(ty, NONE)) => (
105 :     chkElems ("sequence", ty, es);
106 :     seqTy)
107 :     | IR.E_Seq(es, seqTy as Ty.SeqTy(ty, SOME n)) => (
108 :     if (length es <> n)
109 :     then errFn [
110 :     S "sequence has incorrect number of elements",
111 :     NL, S " expected: ", S(Int.toString n),
112 :     NL, S " found: ", S(Int.toString(length es))
113 :     ]
114 :     else ();
115 :     chkElems ("sequence", ty, es);
116 :     seqTy)
117 :     | IR.E_Seq(es, ty) => (
118 :     errFn [S "unexpected type for sequence: ", TY ty];
119 :     ty)
120 :     (* end case *))
121 :     and chkElems (cxt, ty, []) = ()
122 :     | chkElems (cxt, ty, e::es) = let
123 :     val ty' = chk e
124 :     in
125 :     if Ty.same(ty, ty')
126 :     then ()
127 :     else errFn [
128 :     S "element of ", S cxt, S " has incorrect type",
129 :     NL, S "expected: ", TY ty,
130 :     NL, S "found: ", TY ty'
131 :     ];
132 :     chkElems (cxt, ty, es)
133 :     end
134 :     in
135 :     chk e
136 :     end
137 :     fun chkStm (stm, bvs) = (case stm
138 :     of IR.S_Comment _ => bvs
139 :     | IR.S_Assign(xs, e) => let
140 :     fun chkVar (x, ty) = if Ty.same(Var.ty x, ty)
141 :     then ()
142 :     else errFn[
143 :     S "type mismatch in assignment to ", S(Var.name x),
144 :     NL, S "lhs: ", TY(Var.ty x),
145 :     NL, S "rhs: ", TY ty
146 :     ]
147 :     in
148 :     case (xs, chkExp (bvs, e))
149 :     of (_, Ty.CompVecTy dd) => (
150 :     if (List.length xs <> List.length dd)
151 :     then errFn [
152 :     S "arity mismatch in assigning composite vector",
153 :     NL, S" lhs arity: ", S(Int.toString(List.length xs)),
154 :     NL, S" rhs arity: ", S(Int.toString(List.length dd))
155 :     ]
156 :     else ();
157 :     ListPair.app (fn (sv, d) => chkVar(sv, Ty.VecTy d)) (xs, dd))
158 :     | ([sv], ty) => chkVar (sv, ty)
159 :     | (_::_, ty) => errFn [
160 :     S "assignment of non-composite value to (",
161 :     S(String.concatWithMap "," Var.name xs), S ")"
162 :     ]
163 :     (* end case *);
164 :     bvs
165 :     end
166 :     | IR.S_GAssign(gv, e) => let
167 :     val ty = chkExp (bvs, e)
168 :     in
169 :     if Ty.same(GVar.ty gv, ty)
170 :     then ()
171 :     else errFn[
172 :     S "type mismatch in assignment to global ", S(GVar.name gv),
173 :     NL, S "lhs: ", TY(GVar.ty gv),
174 :     NL, S "rhs: ", TY ty
175 :     ];
176 :     bvs
177 :     end
178 :     | IR.S_IfThen(e, b) => let
179 :     val ty = chkExp (bvs, e)
180 :     in
181 :     if Ty.same(ty, Ty.BoolTy)
182 :     then ()
183 :     else errFn[
184 :     S "expected bool for if-then, but found ", TY ty
185 :     ];
186 :     chkBlock (bvs, b);
187 :     bvs
188 :     end
189 :     | IR.S_IfThenElse(e, b1, b2) => let
190 :     val ty = chkExp (bvs, e)
191 :     in
192 :     if Ty.same(ty, Ty.BoolTy)
193 :     then ()
194 :     else errFn[
195 :     S "expected bool for if-then-else, but found ", TY ty
196 :     ];
197 :     chkBlock (bvs, b1);
198 :     chkBlock (bvs, b2);
199 :     bvs
200 :     end
201 :     | IR.S_Foreach(x, e, b) => (
202 :     case chkExp (bvs, e)
203 :     of Ty.SeqTy(ty, _) =>
204 :     if Ty.same(ty, Var.ty x)
205 :     then ()
206 :     else errFn [
207 :     S "type mismatch in foreach ", V x,
208 :     NL, S "variable type: ", TY(Var.ty x),
209 :     NL, S "domain type: ", TY ty
210 :     ]
211 :     | ty => errFn [
212 :     S "domain of foreach is not sequence type; found ", TY ty
213 :     ]
214 :     (* end case *);
215 :     ignore (chkBlock (VSet.add(bvs, x), b));
216 :     bvs)
217 :     | IR.S_LoadNrrd(x, name) => bvs (* FIXME: check type if x *)
218 :     | IR.S_Input(gv, _, _, NONE) => bvs
219 :     | IR.S_Input(gv, _, _, SOME e) => let
220 :     val ty = chkExp (bvs, e)
221 :     in
222 :     if Ty.same(GVar.ty gv, ty)
223 :     then ()
224 :     else errFn[
225 :     S "type mismatch in default for input ", S(GVar.name gv),
226 :     NL, S "expected: ", TY(GVar.ty gv),
227 :     NL, S "found: ", TY ty
228 :     ];
229 :     bvs
230 :     end
231 :     | IR.S_InputNrrd(gv, _, _, _) => (
232 :     case GVar.ty gv
233 :     of Ty.SeqTy(_, NONE) => ()
234 :     | Ty.ImageTy _ => ()
235 :     | ty => errFn [
236 :     S "input variable ", S(GVar.name gv), S " has bogus type ",
237 :     TY ty, S " for lhs for InputNrrd"
238 :     ]
239 :     (* end case *);
240 :     bvs)
241 :     | IR.S_New(_, es) => (
242 :     List.app (fn e => ignore (chkExp(bvs, e))) es;
243 :     bvs)
244 :     | IR.S_Save(svs, e) => let
245 :     fun chkVar (sv, ty) = if Ty.same(SVar.ty sv, ty)
246 :     then ()
247 :     else errFn[
248 :     S "type mismatch in assignment to state variable ",
249 :     S(SVar.name sv),
250 :     NL, S "lhs: ", TY(SVar.ty sv),
251 :     NL, S "rhs: ", TY ty
252 :     ]
253 :     in
254 :     case (svs, chkExp (bvs, e))
255 :     of (_, Ty.CompVecTy dd) => (
256 :     if (List.length svs <> List.length dd)
257 :     then errFn [
258 :     S "arity mismatch in assigning composite vector",
259 :     NL, S" lhs arity: ", S(Int.toString(List.length svs)),
260 :     NL, S" rhs arity: ", S(Int.toString(List.length dd))
261 :     ]
262 :     else ();
263 :     ListPair.app (fn (sv, d) => chkVar(sv, Ty.VecTy d)) (svs, dd))
264 :     | ([sv], ty) => chkVar (sv, ty)
265 :     | (_::_, ty) => errFn [
266 :     S "assignment of non-composite value to (",
267 :     S(String.concatWithMap "," SVar.name svs), S ")"
268 :     ]
269 :     (* end case *);
270 :     bvs
271 :     end
272 :     | IR.S_Exit es => (
273 :     List.app (fn e => ignore (chkExp(bvs, e))) es;
274 :     bvs)
275 :     | IR.S_Active => bvs
276 :     | IR.S_Stabilize => bvs
277 :     | IR.S_Die => bvs
278 :     (* end case *))
279 :     val bvs = List.foldl VSet.add' bvs locals
280 :     in
281 :     ignore (List.foldl chkStm bvs body)
282 :     end
283 :     fun chkOptBlock (_, NONE) = ()
284 :     | chkOptBlock (bvs, SOME blk) = ignore (chkBlock (bvs, blk))
285 :     fun chkStrand (IR.Strand{name, params, state, stateInit, initM, updateM, stabilizeM}) = (
286 :     ignore (chkBlock (VSet.fromList params, stateInit));
287 :     chkOptBlock (VSet.empty, initM);
288 :     ignore (chkBlock (VSet.empty, updateM));
289 :     chkOptBlock (VSet.empty, stabilizeM))
290 :     in
291 :     ignore (chkBlock (VSet.empty, constInit));
292 :     ignore (chkBlock (VSet.empty, globalInit));
293 :     chkStrand strand;
294 :     case create of IR.Create{code, ...} => ignore (chkBlock (VSet.empty, code));
295 :     chkOptBlock (VSet.empty, update);
296 :     final ()
297 :     end
298 :    
299 :     end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0