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 5286 - (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 : jhr 5164 * COPYRIGHT (c) 2017 The University of Chicago
6 : jhr 3754 * All rights reserved.
7 :     *
8 :     * TODO: check global and state variable consistency
9 :     *)
10 :    
11 : jhr 4310 (* FIXME: the checking function should be parameterized over the vector layout of the target *)
12 : jhr 3757
13 : jhr 3754 structure CheckTree : sig
14 :    
15 :     val check : string * TreeIR.program -> bool
16 :    
17 :     end = struct
18 :    
19 :     structure IR = TreeIR
20 :     structure Op = TreeOps
21 : jhr 3861 structure Ty = TreeTypes
22 : jhr 3832 structure GVar = TreeGlobalVar
23 :     structure SVar = TreeStateVar
24 :     structure Var = TreeVar
25 : jhr 3754 structure VSet = Var.Set
26 :    
27 :     datatype token
28 : jhr 3889 = NL | S of string | I of int | A of Atom.atom | V of IR.var
29 : jhr 3810 | TY of Ty.t | TYS of Ty.t list
30 : jhr 3754
31 :     fun error errBuf toks = let
32 :     fun tok2str NL = "\n ** "
33 :     | tok2str (S s) = s
34 : jhr 4317 | tok2str (I i) = Int.toString i
35 : jhr 3754 | tok2str (A s) = Atom.toString s
36 :     | tok2str (V x) = Var.toString x
37 :     | tok2str (TY ty) = Ty.toString ty
38 :     | tok2str (TYS []) = "()"
39 :     | tok2str (TYS[ty]) = Ty.toString ty
40 :     | tok2str (TYS tys) = String.concat[
41 :     "(", String.concatWith " * " (List.map Ty.toString tys), ")"
42 :     ]
43 :     in
44 :     errBuf := concat ("**** Error: " :: List.map tok2str toks)
45 :     :: !errBuf
46 :     end
47 :    
48 : jhr 3861 exception BadVecType of int
49 : jhr 4054 exception InvalidOp of string * Ty.t
50 : jhr 3861
51 : jhr 4051 fun chkIndex (idx, bnd) = ((0 <= idx) andalso (idx < bnd))
52 :    
53 : jhr 4265 (* turn an expression of type TensorTy to one of TensorTyRef *)
54 :     fun mkRefTy (Ty.TensorTy(shp as _::_)) = Ty.TensorRefTy shp
55 :     | mkRefTy ty = ty
56 :    
57 : jhr 3757 (* Return the signature of a TreeIR operator. *)
58 : jhr 3861 fun sigOfOp (vecTy, rator) = (case rator
59 : jhr 3757 of Op.IAdd => (Ty.IntTy, [Ty.IntTy, Ty.IntTy])
60 :     | Op.ISub => (Ty.IntTy, [Ty.IntTy, Ty.IntTy])
61 :     | Op.IMul => (Ty.IntTy, [Ty.IntTy, Ty.IntTy])
62 :     | Op.IDiv => (Ty.IntTy, [Ty.IntTy, Ty.IntTy])
63 :     | Op.IMod => (Ty.IntTy, [Ty.IntTy, Ty.IntTy])
64 :     | Op.INeg => (Ty.IntTy, [Ty.IntTy])
65 : jhr 3870 | Op.RAdd => (Ty.realTy, [Ty.realTy, Ty.realTy])
66 :     | Op.RSub => (Ty.realTy, [Ty.realTy, Ty.realTy])
67 :     | Op.RMul => (Ty.realTy, [Ty.realTy, Ty.realTy])
68 :     | Op.RDiv => (Ty.realTy, [Ty.realTy, Ty.realTy])
69 :     | Op.RNeg => (Ty.realTy, [Ty.realTy])
70 :     | Op.RClamp => (Ty.realTy, [Ty.realTy, Ty.realTy, Ty.realTy])
71 :     | Op.RLerp => (Ty.realTy, [Ty.realTy, Ty.realTy, Ty.realTy])
72 : jhr 3880 | Op.RCeiling => (Ty.realTy, [Ty.realTy])
73 :     | Op.RFloor => (Ty.realTy, [Ty.realTy])
74 :     | Op.RRound => (Ty.realTy, [Ty.realTy])
75 :     | Op.RTrunc => (Ty.realTy, [Ty.realTy])
76 :     | Op.RealToInt => (Ty.IntTy, [Ty.realTy])
77 : jhr 3757 | Op.LT ty => (Ty.BoolTy, [ty, ty])
78 :     | Op.LTE ty => (Ty.BoolTy, [ty, ty])
79 :     | Op.EQ ty => (Ty.BoolTy, [ty, ty])
80 :     | Op.NEQ ty => (Ty.BoolTy, [ty, ty])
81 :     | Op.GT ty => (Ty.BoolTy, [ty, ty])
82 :     | Op.GTE ty => (Ty.BoolTy, [ty, ty])
83 : jhr 4434 | Op.BAnd => (Ty.BoolTy, [Ty.BoolTy, Ty.BoolTy])
84 :     | Op.BOr => (Ty.BoolTy, [Ty.BoolTy, Ty.BoolTy])
85 :     | Op.BNot => (Ty.BoolTy, [Ty.BoolTy])
86 : jhr 3757 | Op.Abs ty => (ty, [ty])
87 :     | Op.Max ty => (ty, [ty, ty])
88 :     | Op.Min ty => (ty, [ty, ty])
89 : jhr 3870 | Op.VAdd d => (vecTy d, [vecTy d, vecTy d])
90 :     | Op.VSub d => (vecTy d, [vecTy d, vecTy d])
91 :     | Op.VScale d => (vecTy d, [Ty.realTy, vecTy d])
92 :     | Op.VMul d => (vecTy d, [vecTy d, vecTy d])
93 :     | Op.VNeg d => (vecTy d, [vecTy d])
94 :     | Op.VSum d => (Ty.realTy, [vecTy d])
95 : jhr 4056 | Op.VDot d => (Ty.realTy, [vecTy d, vecTy d])
96 : jhr 4051 | Op.VIndex(d, pw, idx) =>
97 : jhr 4317 if chkIndex (idx, d)
98 :     then (Ty.realTy, [vecTy(d, pw)])
99 :     else raise InvalidOp("invalid index", Ty.realTy)
100 : jhr 3880 | Op.VCeiling d => (vecTy d, [vecTy d])
101 :     | Op.VFloor d => (vecTy d, [vecTy d])
102 :     | Op.VRound d => (vecTy d, [vecTy d])
103 :     | Op.VTrunc d => (vecTy d, [vecTy d])
104 : jhr 5139 | Op.VToInt layout =>
105 :     (Ty.SeqTy(Ty.IntTy, SOME(#wid layout)), Ty.piecesOf layout)
106 : jhr 4825 | Op.TensorIndex(ty as Ty.TensorTy shp, idxs) =>
107 :     if ListPair.allEq chkIndex (idxs, shp)
108 :     then (Ty.realTy, [ty])
109 :     else raise InvalidOp("invalid index", Ty.realTy)
110 : jhr 4317 | Op.TensorIndex(ty as Ty.TensorRefTy shp, idxs) =>
111 :     if ListPair.allEq chkIndex (idxs, shp)
112 :     then (Ty.realTy, [ty])
113 :     else raise InvalidOp("invalid index", Ty.realTy)
114 :     | Op.ProjectLast(ty as Ty.TensorTy(shp as _::_::_), idxs) => let
115 :     fun chk ([], [_]) = true
116 :     | chk (idx::idxs, d::dd) = chkIndex (idx, d) andalso chk (idxs, dd)
117 :     | chk _ = false
118 :     in
119 :     if chk (idxs, shp)
120 :     then (Ty.TensorRefTy[List.last shp], [ty])
121 :     else raise InvalidOp("invalid index", Ty.TensorRefTy[List.last shp])
122 :     end
123 :     | Op.ProjectLast(ty as Ty.TensorRefTy(shp as _::_::_), idxs) => let
124 :     fun chk ([], [_]) = true
125 :     | chk (idx::idxs, d::dd) = chkIndex (idx, d) andalso chk (idxs, dd)
126 :     | chk _ = false
127 :     in
128 :     if chk (idxs, shp)
129 :     then (Ty.TensorRefTy[List.last shp], [ty])
130 :     else raise InvalidOp("invalid index", Ty.TensorRefTy[List.last shp])
131 :     end
132 :     | Op.TensorCopy shp => (Ty.TensorTy shp, [Ty.TensorRefTy shp])
133 :     | Op.TensorRef shp => (Ty.TensorRefTy shp, [Ty.TensorTy shp])
134 : jhr 3955 | Op.EigenVals2x2 => (Ty.SeqTy(Ty.realTy, SOME 2), [Ty.TensorRefTy[2, 2]])
135 :     | Op.EigenVals3x3 => (Ty.SeqTy(Ty.realTy, SOME 3), [Ty.TensorRefTy[3, 3]])
136 : jhr 3757 | Op.Select(ty as Ty.TupleTy tys, i) => (List.nth(tys, i-1), [ty])
137 : jhr 4265 | Op.Subscript(ty as Ty.SeqTy(elemTy, _)) => (mkRefTy elemTy, [ty, Ty.intTy])
138 : jhr 3757 | Op.MkDynamic(ty, n) => (Ty.SeqTy(ty, NONE), [Ty.SeqTy(ty, SOME n)])
139 : jhr 4412 | Op.Prepend(seqTy,elemTy) => (Ty.SeqTy(seqTy, NONE), [elemTy, Ty.SeqTy(seqTy, NONE)])
140 :     | Op.Append(seqTy,elemTy) => (Ty.SeqTy(seqTy, NONE), [Ty.SeqTy(seqTy, NONE), elemTy])
141 : jhr 3757 | Op.Concat ty => (Ty.SeqTy(ty, NONE), [Ty.SeqTy(ty, NONE), Ty.SeqTy(ty, NONE)])
142 : jhr 3870 | Op.Range => (Ty.SeqTy(Ty.intTy, NONE), [Ty.IntTy, Ty.IntTy])
143 : jhr 3757 | Op.Length ty => (Ty.intTy, [Ty.SeqTy(ty, NONE)])
144 : jhr 4349 | Op.SphereQuery(1, strandTy) =>
145 :     (Ty.SeqTy(strandTy, NONE), [Ty.realTy, Ty.realTy])
146 :     | Op.SphereQuery(dim, strandTy) =>
147 :     (Ty.SeqTy(strandTy, NONE), [Ty.TensorRefTy[dim], Ty.realTy])
148 : jhr 3870 | Op.Sqrt => (Ty.realTy, [Ty.realTy])
149 :     | Op.Cos => (Ty.realTy, [Ty.realTy])
150 :     | Op.ArcCos => (Ty.realTy, [Ty.realTy])
151 :     | Op.Sin => (Ty.realTy, [Ty.realTy])
152 :     | Op.ArcSin => (Ty.realTy, [Ty.realTy])
153 :     | Op.Tan => (Ty.realTy, [Ty.realTy])
154 :     | Op.ArcTan => (Ty.realTy, [Ty.realTy])
155 :     | Op.Exp => (Ty.realTy, [Ty.realTy])
156 : cchiw 5285 | Op.Sgn => (Ty.realTy, [Ty.realTy])
157 : jhr 3757 | Op.IntToReal => (Ty.realTy, [Ty.intTy])
158 : jhr 4394 | Op.NumStrands _ => (Ty.IntTy, [])
159 : jhr 3870 | Op.Transform info => let
160 : jhr 3757 val dim = ImageInfo.dim info
161 :     in
162 : jhr 3870 if (dim = 1)
163 : jhr 3886 then (Ty.realTy, [Ty.ImageTy info])
164 : jhr 3955 else (Ty.TensorRefTy[dim, dim], [Ty.ImageTy info])
165 : jhr 3757 end
166 : jhr 3870 | Op.Translate info => let
167 : jhr 3757 val dim = ImageInfo.dim info
168 :     in
169 : jhr 3870 if (dim = 1)
170 : jhr 3886 then (Ty.realTy, [Ty.ImageTy info])
171 : jhr 3955 else (Ty.TensorRefTy[dim], [Ty.ImageTy info])
172 : jhr 3757 end
173 : jhr 3870 | Op.ControlIndex(info, _, _) => (Ty.IntTy, [Ty.ImageTy info, Ty.IntTy])
174 : jhr 4317 | Op.LoadVoxel info => (Ty.realTy, [Ty.ImageTy info, Ty.IntTy])
175 :     | Op.Inside(layout, info, _) =>
176 :     (Ty.BoolTy, TreeTypes.piecesOf layout @ [Ty.ImageTy info])
177 : jhr 4185 | Op.IndexInside(info, _) => let
178 : jhr 4317 val idxTy = (case ImageInfo.dim info
179 :     of 1 => Ty.IntTy
180 :     | d => Ty.SeqTy(Ty.IntTy, SOME d)
181 :     (* end case *))
182 :     in
183 :     (Ty.BoolTy, [idxTy, Ty.ImageTy info])
184 :     end
185 : jhr 3757 | Op.ImageDim(info, _) => (Ty.IntTy, [Ty.ImageTy info])
186 : jhr 3870 | Op.MathFn f => MathFns.sigOf (Ty.realTy, f)
187 : jhr 3757 | _ => raise Fail("sigOf: invalid operator " ^ Op.toString rator)
188 :     (* end case *))
189 :    
190 : jhr 4265 (* utility function for synthesizing eigenvector/eigenvalue signature *)
191 :     fun eigenSig dim = let
192 :     val resTy = [
193 :     Ty.SeqTy(Ty.realTy, SOME dim),
194 :     Ty.SeqTy(Ty.TensorTy[dim], SOME dim)
195 :     ]
196 :     in
197 :     (resTy, [Ty.TensorTy[dim, dim]])
198 :     end
199 :    
200 :     fun msigOf rator = (case rator
201 :     of Op.EigenVecs2x2 => eigenSig 2
202 :     | Op.EigenVecs3x3 => eigenSig 3
203 :     | _ => raise Fail("msigOf: invalid operator " ^ Op.toString rator)
204 :     (* end case *))
205 :    
206 : jhr 3754 fun check (phase, prog) = let
207 : jhr 3870 val IR.Program{
208 :     props, target={layout, ...}, consts, inputs, constInit,
209 : jhr 4491 globals, funcs, globInit, strand, create, start, update
210 : jhr 3870 } = prog
211 : jhr 3754 val errBuf = ref []
212 :     val errFn = error errBuf
213 : jhr 4825 (* handle exceptions *)
214 :     fun onExn exn =
215 :     errFn (S "uncaught exception: " :: S(exnMessage exn) ::
216 :     List.foldr (fn (s, msg) => NL :: S " raised at " :: S s :: msg)
217 :     [] (SMLofNJ.exnHistory exn))
218 : jhr 3754 fun final () = (case !errBuf
219 :     of [] => false
220 :     | errs => (
221 :     Log.msg ["********** IR Errors detected after ", phase, " **********\n"];
222 :     List.app (fn msg => Log.msg [msg, "\n"]) (List.rev errs);
223 :     true)
224 :     (* end case *))
225 : jhr 3870 fun sigOf rator = let
226 : jhr 3880 fun vecTy (d, pw) = let
227 : jhr 4317 fun invalid () = (
228 :     errFn [
229 : jhr 3889 S "invalid width ", I d, S " for ", S(Op.toString rator)
230 : jhr 3870 ];
231 : jhr 3880 Ty.VecTy(d, pw))
232 : jhr 4317 in
233 :     case layout d
234 :     of {padded, pieces=[w], ...} =>
235 :     if (w <> pw) then invalid() else Ty.VecTy(d, w)
236 :     | _ => invalid ()
237 :     (* end case *)
238 :     end
239 : jhr 3870 in
240 :     sigOfOp (vecTy, rator)
241 :     end
242 : jhr 3754 (* check a variable use *)
243 :     fun checkVar (bvs, x) = if VSet.member(bvs, x)
244 :     then ()
245 :     else errFn [S "variable ", V x, S " is not bound"]
246 : jhr 3870 fun chkBlock (bvs : VSet.set, IR.Block{locals, body}) = let
247 :     fun chkExp (cxt, bvs : VSet.set, e) = let
248 :     fun chk e = (case e
249 : jhr 4033 of IR.E_Global gv => GVar.ty gv
250 :     | IR.E_State(NONE, sv) => SVar.ty sv
251 : jhr 3870 | IR.E_State(SOME e, sv) => (
252 : jhr 4317 case chk e
253 : jhr 4386 of Ty.StrandIdTy _ => ()
254 : jhr 4317 | ty => errFn [S "expected strand type, but found ", TY ty]
255 :     (* end case *);
256 : jhr 4033 SVar.ty sv)
257 :     | IR.E_Var x => (checkVar(bvs, x); Var.ty x)
258 : jhr 3870 | IR.E_Lit(Literal.Int _) => Ty.IntTy
259 :     | IR.E_Lit(Literal.Real _) => Ty.realTy
260 :     | IR.E_Lit(Literal.String _) => Ty.StringTy
261 :     | IR.E_Lit(Literal.Bool _) => Ty.BoolTy
262 : jhr 4054 | IR.E_Op(rator, args) => (let
263 : jhr 3870 val (resTy, paramTys) = sigOf rator
264 :     val argTys = List.map chk args
265 :     in
266 : jhr 4033 if ListPair.allEq Ty.same (paramTys, argTys)
267 : jhr 3870 then ()
268 :     else errFn [
269 :     S "argument type mismatch in application of ",
270 :     S(Op.toString rator), S(cxt()),
271 :     NL, S "expected: ", TYS paramTys,
272 :     NL, S "found: ", TYS argTys
273 :     ];
274 :     resTy
275 :     end
276 : jhr 4317 handle InvalidOp(msg, ty) => (errFn [
277 :     S msg, S " in operator ", S(Op.toString rator)
278 :     ]; ty))
279 :     | IR.E_Apply(f, args) => let
280 :     val (resTy, paramTys) = TreeFunc.ty f
281 :     val argTys = List.map chk args
282 : jhr 4163 in
283 :     if ListPair.allEq Ty.same (paramTys, argTys)
284 :     then ()
285 :     else errFn [
286 :     S "argument type mismatch in application of ",
287 :     S(TreeFunc.toString f), S(cxt()),
288 :     NL, S "expected: ", TYS paramTys,
289 :     NL, S "found: ", TYS argTys
290 :     ];
291 :     resTy
292 :     end
293 : jhr 3889 | IR.E_Vec(w, pw, es) => let
294 : jhr 3870 fun chkArg (i, e) = (case chk e
295 :     of Ty.VecTy(1, 1) => () (* ok *)
296 :     | ty => errFn [
297 : jhr 3889 S "component ", I i,
298 : jhr 3870 S " of vector does has type ", TY ty, S(cxt())
299 :     ])
300 : jhr 3889 val ty = Ty.VecTy(w, pw)
301 : jhr 3870 in
302 :     List.appi chkArg es;
303 : jhr 4317 if (length es <> w)
304 :     then errFn [
305 :     S "expected ", I w,
306 :     S " arguments to E_Vec, but found ", I(length es)
307 :     ]
308 :     else ();
309 : jhr 3870 ty
310 :     end
311 :     | IR.E_Cons([], ty) => (
312 :     errFn [S "empty cons", S(cxt())];
313 :     ty)
314 :     | IR.E_Cons(es, consTy as Ty.TensorTy dd) => let
315 :     val nelems = List.foldl Int.* 1 dd
316 :     in
317 :     if (length es <> nelems)
318 :     then errFn [
319 :     S "cons has incorrect number of elements", S(cxt()),
320 : jhr 3889 NL, S " expected: ", I nelems,
321 :     NL, S " found: ", I(length es)
322 : jhr 3870 ]
323 :     else ();
324 :     chkElems ("cons", Ty.realTy, es);
325 :     consTy
326 :     end
327 :     | IR.E_Cons(es, ty) => (
328 :     errFn [S "unexpected type for cons", S(cxt()), S ": ", TY ty];
329 :     ty)
330 :     | IR.E_Seq([], ty as Ty.SeqTy(_, SOME 0)) => ty
331 :     | IR.E_Seq([], ty as Ty.SeqTy(_, SOME n)) => (
332 :     errFn [S "empty sequence, but expected ", TY ty, S(cxt())];
333 :     ty)
334 :     | IR.E_Seq(es, seqTy as Ty.SeqTy(ty, NONE)) => (
335 :     chkElems ("sequence", ty, es);
336 :     seqTy)
337 :     | IR.E_Seq(es, seqTy as Ty.SeqTy(ty, SOME n)) => (
338 :     if (length es <> n)
339 :     then errFn [
340 :     S "sequence has incorrect number of elements", S(cxt()),
341 : jhr 3889 NL, S " expected: ", I n,
342 :     NL, S " found: ", I(length es)
343 : jhr 3870 ]
344 :     else ();
345 :     chkElems ("sequence", ty, es);
346 :     seqTy)
347 :     | IR.E_Seq(es, ty) => (
348 :     errFn [S "unexpected type for sequence", S(cxt()), S ": ", TY ty];
349 :     ty)
350 :     | IR.E_Pack(layout, es) => let
351 :     fun chkOne (i, ty, ty') = if Ty.same(ty, ty')
352 :     then ()
353 :     else errFn[
354 : jhr 3889 S "mismatch in component ", I i,
355 : jhr 3870 S " of PACK", S(cxt()),
356 :     NL, S " expected: ", TY ty',
357 :     NL, S " found: ", TY ty
358 :     ]
359 :     in
360 :     ListPair.appi chkOne (List.map chk es, Ty.piecesOf layout);
361 :     Ty.TensorTy[#wid layout]
362 :     end
363 :     | IR.E_VLoad(layout, e, i) => let
364 :     val ty = chk e
365 : jhr 3958 val expectedTy = Ty.TensorRefTy[#wid layout]
366 : jhr 3870 in
367 : jhr 4033 if Ty.same(ty, expectedTy)
368 : jhr 3870 then ()
369 :     else errFn [
370 : jhr 3958 S "type mismatch in E_VLoad", S(cxt()),
371 : jhr 3870 NL, S " expected: ", TY expectedTy,
372 :     NL, S " found: ", TY ty
373 :     ];
374 :     Ty.nthVec(layout, i)
375 :     end
376 :     (* end case *))
377 :     and chkElems (cxt', ty, []) = ()
378 :     | chkElems (cxt', ty, e::es) = let
379 :     val ty' = chk e
380 :     in
381 :     if Ty.same(ty, ty')
382 :     then ()
383 :     else errFn [
384 :     S "element of ", S cxt', S " has incorrect type", S(cxt()),
385 :     NL, S "expected: ", TY ty,
386 :     NL, S "found: ", TY ty'
387 :     ];
388 :     chkElems (cxt', ty, es)
389 :     end
390 :     in
391 :     chk e
392 :     end
393 :     fun chkStm (stm, bvs : VSet.set) = (case stm
394 :     of IR.S_Comment _ => bvs
395 :     | IR.S_Assign(isDef, x, e) => let
396 :     val ty = chkExp (
397 :     fn () => concat[" in assignment to local ", Var.name x],
398 :     bvs, e)
399 :     in
400 :     if Ty.same(Var.ty x, ty)
401 :     then ()
402 :     else errFn[
403 :     S "type mismatch in assignment to local ", S(Var.name x),
404 :     NL, S "lhs: ", TY(Var.ty x),
405 :     NL, S "rhs: ", TY ty
406 :     ];
407 :     if isDef
408 :     then VSet.add(bvs, x)
409 :     else (checkVar(bvs, x); bvs)
410 :     end
411 : jhr 4265 | IR.S_MAssign(xs, IR.E_Op(rator, es)) => let
412 : jhr 4317 val lhsTys = List.map TreeVar.ty xs
413 :     val argTys = List.map (fn e => chkExp (fn _ => "", bvs, e)) es
414 :     val (resTys, paramTys) = msigOf rator
415 :     in
416 : jhr 4265 (* FIXME: complete *)
417 : jhr 4317 bvs
418 :     end
419 : jhr 4265 | IR.S_MAssign _ => (errFn[S "ill-formed MAssign"]; bvs)
420 : jhr 3870 | IR.S_GAssign(gv, e) => let
421 :     val ty = chkExp (
422 :     fn () => concat[" assignment to global ", GVar.name gv],
423 :     bvs, e)
424 :     in
425 :     if Ty.same(GVar.ty gv, ty)
426 :     then ()
427 :     else errFn[
428 :     S "type mismatch in assignment to global ", S(GVar.name gv),
429 :     NL, S "lhs: ", TY(GVar.ty gv),
430 :     NL, S "rhs: ", TY ty
431 :     ];
432 :     bvs
433 :     end
434 :     | IR.S_IfThen(e, b) => let
435 :     val ty = chkExp (fn () => " in if-then", bvs, e)
436 :     in
437 :     if Ty.same(ty, Ty.BoolTy)
438 :     then ()
439 :     else errFn[
440 :     S "expected bool for if-then, but found ", TY ty
441 :     ];
442 :     chkBlock (bvs, b);
443 :     bvs
444 :     end
445 :     | IR.S_IfThenElse(e, b1, b2) => let
446 :     val ty = chkExp (fn () => " in if-then-else", bvs, e)
447 :     in
448 :     if Ty.same(ty, Ty.BoolTy)
449 :     then ()
450 :     else errFn[
451 :     S "expected bool for if-then-else, but found ", TY ty
452 :     ];
453 :     chkBlock (bvs, b1);
454 :     chkBlock (bvs, b2);
455 :     bvs
456 :     end
457 : jhr 4317 | IR.S_For(x, e1, e2, b) => let
458 :     fun chkE e = (case chkExp (fn () => " in for", bvs, e)
459 :     of Ty.IntTy => ()
460 :     | ty => errFn [
461 :     S "bound of for is not int type; found ", TY ty
462 :     ]
463 :     (* end case *))
464 :     in
465 :     if (Ty.same(Ty.IntTy, Var.ty x))
466 :     then ()
467 :     else errFn [
468 :     S "iteration variable ", V x,
469 :     S " in for loop has type ", TY(Var.ty x)
470 :     ];
471 :     chkE e1; chkE e2;
472 :     ignore (chkBlock (VSet.add(bvs, x), b));
473 :     bvs
474 :     end
475 : jhr 3870 | IR.S_Foreach(x, e, b) => (
476 :     case chkExp (fn () => " in foreach", bvs, e)
477 :     of Ty.SeqTy(ty, _) =>
478 :     if Ty.same(ty, Var.ty x)
479 :     then ()
480 :     else errFn [
481 :     S "type mismatch in foreach ", V x,
482 :     NL, S "variable type: ", TY(Var.ty x),
483 :     NL, S "domain type: ", TY ty
484 :     ]
485 :     | ty => errFn [
486 :     S "domain of foreach is not sequence type; found ", TY ty
487 :     ]
488 :     (* end case *);
489 :     ignore (chkBlock (VSet.add(bvs, x), b));
490 :     bvs)
491 : jhr 4434 | IR.S_MapReduce(mrs, src) =>
492 : jhr 4380 (* FIXME: check body of map-reduce *)
493 : jhr 4434 List.foldl
494 :     (fn (IR.MapReduce(lhs, _, _, _, _), bvs) => VSet.add(bvs, lhs))
495 :     bvs mrs
496 : jhr 5184 | IR.S_LoadNrrd(x, ty, name, proxy) =>
497 :     VSet.add(bvs, x) (* FIXME: check type of x *)
498 : jhr 3870 | IR.S_Input(gv, _, _, NONE) => bvs
499 :     | IR.S_Input(gv, _, _, SOME e) => let
500 :     val ty = chkExp (fn () => concat[" in input ", GVar.name gv], bvs, e)
501 :     in
502 :     if Ty.same(GVar.ty gv, ty)
503 :     then ()
504 :     else errFn[
505 :     S "type mismatch in default for input ", S(GVar.name gv),
506 :     NL, S "expected: ", TY(GVar.ty gv),
507 :     NL, S "found: ", TY ty
508 :     ];
509 :     bvs
510 :     end
511 :     | IR.S_InputNrrd(gv, _, _, _) => (
512 :     case GVar.ty gv
513 :     of Ty.SeqTy(_, NONE) => ()
514 :     | Ty.ImageTy _ => ()
515 :     | ty => errFn [
516 :     S "input variable ", S(GVar.name gv), S " has bogus type ",
517 :     TY ty, S " for lhs for InputNrrd"
518 :     ]
519 :     (* end case *);
520 :     bvs)
521 :     | IR.S_New(_, es) => (
522 :     List.app (fn e => ignore (chkExp(fn () => concat[" in new"], bvs, e))) es;
523 :     bvs)
524 :     | IR.S_Save(sv, e) => let
525 :     val ty = chkExp (fn () => concat[" in save ", SVar.name sv], bvs, e)
526 :     in
527 :     if Ty.same(SVar.ty sv, ty)
528 :     then ()
529 :     else errFn[
530 :     S "type mismatch in assignment to state variable ",
531 :     S(SVar.name sv),
532 :     NL, S "lhs: ", TY(SVar.ty sv),
533 :     NL, S "rhs: ", TY ty
534 :     ];
535 :     bvs
536 :     end
537 : jhr 4628 | IR.S_KillAll => bvs
538 : jhr 4472 | IR.S_StabilizeAll => bvs
539 : jhr 3870 | IR.S_Print(tys, es) => (
540 :     if (length tys <> length es)
541 : jhr 3965 then errFn [S "arity mismatch in print statement"]
542 : jhr 3870 else ();
543 :     ListPair.appi
544 :     (fn (i, ty, e) => let
545 :     val ty' = chkExp(fn () => concat[" in print"], bvs, e)
546 :     in
547 : jhr 4033 if Ty.same(ty', ty)
548 : jhr 3870 then ()
549 :     else errFn[
550 : jhr 3889 S "type mismatch in argument ", I i,
551 : jhr 3870 S " of print",
552 :     NL, S "expected: ", TY ty,
553 :     NL, S "but found: ", TY ty'
554 :     ]
555 :     end)
556 :     (tys, es);
557 :     bvs)
558 : jhr 5286 | IR.S_Return NONE => bvs
559 :     | IR.S_Return(SOME e) => (
560 : jhr 4480 ignore (chkExp (fn () => concat[" in return"], bvs, e));
561 :     bvs)
562 : jhr 3870 | IR.S_Active => bvs
563 :     | IR.S_Stabilize => bvs
564 :     | IR.S_Die => bvs
565 :     (* end case *))
566 :     val bvs = VSet.addList(bvs, !locals)
567 :     in
568 :     ignore (List.foldl chkStm bvs body)
569 :     end
570 : jhr 5139 fun checkBlock arg = (ignore (chkBlock arg) handle ex => onExn ex)
571 : jhr 3870 fun chkOptBlock (_, NONE) = ()
572 : jhr 4825 | chkOptBlock (bvs, SOME blk) = checkBlock (bvs, blk)
573 :     fun chkMethod (bvs, IR.Method{body, ...}) = checkBlock (bvs, body)
574 : jhr 4317 fun chkOptMethod (_, NONE) = ()
575 :     | chkOptMethod (bvs, SOME meth) = chkMethod (bvs, meth)
576 : jhr 4491 fun chkStrand (IR.Strand{params, state, stateInit, startM, updateM, stabilizeM, ...}) = (
577 : jhr 3952 ignore (chkMethod (VSet.fromList params, stateInit));
578 : jhr 4491 chkOptMethod (VSet.empty, startM);
579 : jhr 3952 ignore (chkMethod (VSet.empty, updateM));
580 :     chkOptMethod (VSet.empty, stabilizeM))
581 : jhr 4317 fun chkInput (Inputs.INP{var, ...}) = if GVar.isInput var
582 :     then ()
583 :     else errFn[S "non-input variable ", S(GVar.name var), S " in inputs list"]
584 :     fun chkGlobal gv = if GVar.isInput gv
585 :     then errFn[S "input variable ", S(GVar.name gv), S " in globals list"]
586 :     else ()
587 : jhr 5164 fun chkFunc (IR.Func{name, params, body}) = let
588 :     val (retTy, paramTys) = TreeFunc.ty name
589 :     fun chkParam (x, ty) = Ty.same(Var.ty x, ty)
590 :     in
591 :     if ListPair.allEq chkParam (params, paramTys)
592 :     then ()
593 :     else errFn [
594 :     S "mismatch between parameter-type of ",
595 :     S(TreeFunc.toString name), S " and types of parameters",
596 :     NL, S "parameter type: ", TYS paramTys,
597 :     NL, S "parameters: ", TYS(List.map Var.ty params)
598 :     ];
599 :     (* FIXME: check return type of body against function type *)
600 :     checkBlock (VSet.fromList params, body)
601 :     end
602 : jhr 3870 in
603 : jhr 4317 List.app chkInput inputs;
604 :     List.app chkGlobal globals;
605 :     List.app chkFunc funcs;
606 : jhr 4825 checkBlock (VSet.empty, constInit);
607 :     checkBlock (VSet.empty, globInit);
608 : jhr 3870 chkStrand strand;
609 : jhr 4825 Create.app (fn code => checkBlock (VSet.empty, code)) create;
610 : jhr 4491 chkOptBlock (VSet.empty, start);
611 : jhr 3870 chkOptBlock (VSet.empty, update);
612 :     final ()
613 :     end
614 : jhr 3754
615 :     end

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