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

SCM Repository

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

Annotation of /branches/vis15/src/compiler/typechecker/check-stmt.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4607 - (view) (download)

1 : jhr 3398 (* check-stmt.sml
2 :     *
3 :     * This code is part of the Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     *
5 :     * COPYRIGHT (c) 2015 The University of Chicago
6 :     * All rights reserved.
7 :     *)
8 :    
9 :     structure CheckStmt : sig
10 :    
11 : jhr 3408 (* type check a statement *)
12 : jhr 3407 val check : Env.t * Env.context * ParseTree.stmt -> AST.stmt
13 : jhr 3398
14 : jhr 3408 (* type check a variable declaration *)
15 :     val checkVarDecl : Env.t * Env.context * Var.kind * ParseTree.var_dcl
16 : jhr 4317 -> (Atom.atom * Var.t * AST.expr option)
17 : jhr 3408
18 :     (* check the creation of a new strand; either in a "new" statement or in the
19 :     * initial-strands creation code.
20 :     *)
21 :     val checkStrandCreate : Env.t * Env.context * Atom.atom * ParseTree.expr list -> AST.stmt
22 :    
23 : jhr 3398 end = struct
24 :    
25 :     structure PT = ParseTree
26 : jhr 3407 structure L = Literal
27 : jhr 3398 structure E = Env
28 :     structure Ty = Types
29 : jhr 3408 structure TU = TypeUtil
30 : jhr 3398 structure BV = BasisVars
31 :    
32 :     val chkE = CheckExpr.check
33 :    
34 :     (* a statement to return when there is a type error *)
35 : jhr 3408 fun bogusStm env = (AST.S_Block[], env)
36 : jhr 4565 (* a bogus expression for when there is a type error *)
37 :     val bogusExp = AST.E_Lit(L.Int 0)
38 : jhr 3398
39 : jhr 3408 val err = TypeError.error
40 : jhr 3398 val warn = TypeError.warning
41 :    
42 : jhr 3402 datatype token = datatype TypeError.token
43 : jhr 3398
44 : jhr 3408 (* mark a variable use with its location *)
45 : jhr 3413 fun useVar (cxt : Env.context, x) = (x, #2 cxt)
46 : jhr 3408
47 : jhr 3398 (* typecheck a variable declaration *)
48 :     fun checkVarDecl (env, cxt, kind, d) = (case d
49 :     of PT.VD_Mark m => checkVarDecl (env, (#1 cxt, #span m), kind, #tree m)
50 : jhr 3408 | PT.VD_Decl(ty, {span, tree=x}, optExp) => let
51 :     val ty = CheckType.check (env, cxt, ty)
52 : jhr 4060 val x' = Var.new (x, span, kind, ty)
53 : jhr 4317 in
54 :     case optExp
55 :     of SOME e => let
56 :     val eTy = chkE (env, cxt, e)
57 :     in
58 :     case Util.coerceType (ty, eTy)
59 :     of SOME e' => (x, x', SOME e')
60 :     | NONE => (
61 :     err(cxt, [
62 :     S "type of variable ", A x,
63 :     S " does not match type of initializer\n",
64 :     S " expected: ", TY ty, S "\n",
65 :     S " found: ", TY(#2 eTy)
66 :     ]);
67 : jhr 4565 (x, x', SOME bogusExp))
68 : jhr 4317 (* end case *)
69 :     end
70 :     | NONE => (x, x', NONE)
71 :     end
72 : jhr 3398 (* end case *))
73 :    
74 : jhr 4491 (* check the creation of a new strand; either in a "new" statement or in an "start"
75 : jhr 3408 * block.
76 :     *)
77 :     fun checkStrandCreate (env, cxt, strand, args) = let
78 :     val argsAndTys' = List.map (fn e => CheckExpr.check(env, cxt, e)) args
79 :     val (args', tys') = ListPair.unzip argsAndTys'
80 :     in
81 :     (* check that strand is defined and that the argument types match *)
82 :     case Env.findStrand (env, strand)
83 :     of SOME sEnv => let
84 :     val paramTys = StrandEnv.paramTys sEnv
85 :     in
86 :     case Unify.matchArgs (paramTys, args', tys')
87 :     of SOME args' => AST.S_New(StrandEnv.strandName sEnv, args')
88 :     | NONE => (
89 : jhr 4317 err (cxt, [
90 :     S "type error in new ", A strand, S "\n",
91 :     S " expected: ", TYS paramTys, S "\n",
92 :     S " found: ", TYS tys'
93 :     ]);
94 :     AST.S_Block[])
95 : jhr 3408 (* end case *)
96 :     end
97 :     | NONE => (err (cxt, [S "unknown strand ", A strand]); AST.S_Block[])
98 :     (* end case *)
99 :     end
100 :    
101 : jhr 3398 (* check for unreachable code and non-return statements in the tail position of a function.
102 :     * Note that unreachable code is typechecked and included in the AST. It is pruned away
103 :     * by simplify.
104 :     *)
105 :     fun chkCtlFlow (cxt, scope, stm) = let
106 : jhr 4607 fun inFun () = (case scope of E.FunctionScope _ => true | _ => false)
107 :     fun funName () = let val E.FunctionScope(_, f) = scope in S(Atom.toString f) end
108 :     fun inCreateOrMeth () = (case scope
109 :     of E.MethodScope(_, StrandUtil.Start) => true
110 :     | E.MethodScope(_, StrandUtil.Update) => true
111 :     | E.CreateScope => true
112 :     | _ => false
113 :     (* end case *))
114 :     fun inUpdate () = (case scope
115 :     of E.MethodScope(_, StrandUtil.Update) => true
116 :     | E.UpdateScope => true
117 :     | _ => false
118 :     (* end case *))
119 :     fun inStartOrUpdateMethod () = (case scope
120 :     of E.MethodScope _ => true | _ => false)
121 : jhr 4466 val hasDieOrStabilize = ref false
122 : jhr 3398 (* checks a statement for correct control flow; it returns false if control may
123 :     * flow from the statement to the next in a sequence and true if control cannot
124 : jhr 3432 * flow to the next statement. The parameter flags have the following meaning:
125 : jhr 4317 *
126 :     * hasSucc -- true if the statement has a successor
127 :     * isJoin -- true if the following statement joins multiple control
128 :     * paths
129 :     * unreachable -- true if the previous statement escapes; i.e., control
130 :     * cannot reach this statment.
131 : jhr 3398 *)
132 :     fun chk ((errStrm, _), hasSucc, isJoin, unreachable, PT.S_Mark{span, tree}) =
133 :     chk((errStrm, span), hasSucc, isJoin, unreachable, tree)
134 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Block(stms as _::_)) = let
135 :     fun chk' ([], escapes) = escapes
136 :     | chk' ([stm], escapes) =
137 :     chk(cxt, hasSucc, isJoin, escapes orelse unreachable, stm) orelse escapes
138 :     | chk' (stm::stms, escapes) = let
139 :     val escapes = chk(cxt, true, false, escapes orelse unreachable, stm) orelse escapes
140 :     in
141 :     chk'(stms, escapes)
142 :     end
143 :     in
144 :     chk' (stms, false)
145 :     end
146 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_IfThen(_, stm)) = (
147 : jhr 4607 if inFun() andalso not hasSucc andalso not unreachable
148 : jhr 3398 then err(cxt, [
149 : jhr 4607 S "Missing return statement in tail position of function ", funName()
150 : jhr 3398 ])
151 :     else ();
152 :     ignore (chk (cxt, hasSucc, true, unreachable, stm));
153 :     false)
154 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_IfThenElse(_, stm1, stm2)) = let
155 :     val escapes = chk (cxt, hasSucc, true, unreachable, stm1)
156 :     val escapes = chk (cxt, hasSucc, true, unreachable, stm2) andalso escapes
157 :     in
158 :     if escapes andalso hasSucc andalso not unreachable
159 :     then (
160 :     warn(cxt, [S "unreachable statements after \"if-then-else\" statement"]);
161 :     true)
162 :     else escapes
163 :     end
164 : jhr 4317 | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Foreach(_, _, stm)) = (
165 :     ignore (chk (cxt, hasSucc, true, unreachable, stm));
166 :     false)
167 : jhr 3398 | chk (cxt, _, _, _, PT.S_New _) = (
168 : jhr 4607 case scope
169 :     of E.MethodScope(_, StrandUtil.Start) => ()
170 :     | E.MethodScope(_, StrandUtil.Update) => ()
171 :     | _ => err(cxt, [S "\"new\" statement outside of start/update method"])
172 :     (* end case *);
173 : jhr 3398 false)
174 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Continue) = (
175 : jhr 3432 (* QUESTION: should we allow "continue" in loops? *)
176 : jhr 4607 case scope
177 :     of E.MethodScope(_, StrandUtil.Update) => ()
178 :     | E.UpdateScope => ()
179 :     | _ => if hasSucc andalso not isJoin andalso not unreachable
180 :     then warn(cxt, [S "statements following \"continue\" statment are unreachable"])
181 :     else ()
182 :     (* end case *);
183 : jhr 3398 true)
184 : jhr 4607 | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Stabilize) = let
185 :     (* check strand stabilize *)
186 :     fun chkStabilize () = (
187 :     if (not unreachable) then hasDieOrStabilize := true else ();
188 :     if hasSucc andalso not isJoin andalso not unreachable
189 :     then warn(cxt, [
190 :     S "statements following \"stabilize\" statment are unreachable"
191 :     ])
192 :     else ();
193 :     true)
194 :     in
195 :     case scope
196 :     of E.MethodScope(_, StrandUtil.Start) => chkStabilize ()
197 :     | E.MethodScope(_, StrandUtil.Update) => chkStabilize ()
198 :     | E.StartScope => false (* global stabilize_all; _not_ an exit *)
199 :     | E.UpdateScope => false (* global stabilize_all; _not_ an exit *)
200 :     | _ => (err(cxt, [
201 :     S "\"stabilize\" statment outside of start/update method/block"
202 :     ]);
203 :     false)
204 :     (* end case *)
205 :     end
206 :     | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Die) = let
207 :     (* check strand die *)
208 :     fun chkDie () = (
209 :     if (not unreachable) then hasDieOrStabilize := true else ();
210 :     if hasSucc andalso not isJoin andalso not unreachable
211 :     then warn(cxt, [
212 :     S "statements following \"die\" statment are unreachable"
213 :     ])
214 :     else ();
215 :     true)
216 :     in
217 :     case scope
218 :     of E.MethodScope(_, StrandUtil.Start) => chkDie ()
219 :     | E.MethodScope(_, StrandUtil.Update) => chkDie ()
220 :     | E.StartScope => false (* global stabilize_all; _not_ an exit *)
221 :     | E.UpdateScope => false (* global stabilize_all; _not_ an exit *)
222 :     | _ => (err(cxt, [
223 :     S "\"die\" statment outside of start/update method/block"
224 :     ]);
225 :     false)
226 :     (* end case *)
227 :     end
228 : jhr 3398 | chk (cxt, hasSucc, isJoin, unreachable, PT.S_Return _) = (
229 : jhr 4607 if not(inFun())
230 : jhr 3398 then err(cxt, [S "\"return\" statment outside of function body"])
231 :     else if hasSucc andalso not isJoin andalso not unreachable
232 :     then warn(cxt, [S "statements following \"return\" statment are unreachable"])
233 :     else ();
234 :     true)
235 :     | chk (cxt, hasSucc, isJoin, unreachable, _) = (
236 : jhr 4607 if inFun() andalso not hasSucc andalso not unreachable
237 : jhr 3398 then err(cxt, [
238 : jhr 4607 S "Missing return statement in tail position of function ", funName()
239 : jhr 3398 ])
240 :     else ();
241 :     false)
242 :     in
243 : jhr 4466 ignore (chk (cxt, false, false, false, stm));
244 :     case (!hasDieOrStabilize, scope)
245 :     of (false, E.MethodScope(_, StrandUtil.Update)) =>
246 :     warn (cxt, [S "update method does not have reachable die or stabilize statement"])
247 :     | _ => ()
248 :     (* end case *)
249 : jhr 3398 end
250 :    
251 :     (* check the type of a statement *)
252 :     fun chk (env, cxt, e) = (case e
253 : jhr 4317 of PT.S_Mark m => chk (E.withEnvAndContext (env, cxt, m))
254 :     | PT.S_Block stms => let
255 :     fun chk' (_, [], stms) = AST.S_Block(List.rev stms)
256 :     | chk' (env, s::ss, stms) = let
257 :     val (s', env') = chk (env, cxt, s)
258 :     in
259 :     chk' (env', ss, s'::stms)
260 :     end
261 :     in
262 :     (chk' (Env.blockScope env, stms, []), env)
263 :     end
264 :     | PT.S_IfThen(e, s) => let
265 :     val (e', ty) = chkE (env, cxt, e)
266 :     val (s', _) = chk (env, cxt, s)
267 :     in
268 :     (* check that condition has bool type *)
269 :     case TU.prune ty
270 :     of Ty.T_Bool => ()
271 :     | Ty.T_Error => ()
272 :     | _ => err(cxt, [S "condition not boolean type"])
273 :     (* end case *);
274 :     (AST.S_IfThenElse(e', s', AST.S_Block[]), env)
275 :     end
276 :     | PT.S_IfThenElse(e, s1, s2) => let
277 :     val (e', ty) = chkE (env, cxt, e)
278 :     val (s1', _) = chk (env, cxt, s1)
279 :     val (s2', _) = chk (env, cxt, s2)
280 :     in
281 :     (* check that condition has bool type *)
282 :     case TU.prune ty
283 :     of Ty.T_Bool => ()
284 :     | Ty.T_Error => ()
285 :     | _ => err (cxt, [S "expected type 'bool' for condition, but found ", TY ty])
286 :     (* end case *);
287 :     (AST.S_IfThenElse(e', s1', s2'), env)
288 :     end
289 :     | PT.S_Foreach(ty, iter, body) => let
290 :     val ty = CheckType.check (env, cxt, ty)
291 : jhr 4359 val ((x', e'), env') = CheckExpr.checkIter (E.loopScope env, cxt, iter)
292 : jhr 4317 in
293 :     if Unify.equalType(ty, Var.monoTypeOf x')
294 :     then ()
295 :     else err (cxt, [
296 :     S "type mismatch in iterator\n",
297 :     S " declared element type: ", TY ty, S "\n",
298 :     S " actual element type: ", TY(Var.monoTypeOf x')
299 :     ]);
300 :     (AST.S_Foreach((x', e'), #1 (chk (env', cxt, body))), env)
301 :     end
302 :     | PT.S_Print args => let
303 :     fun chkArg e = let
304 :     val (e', ty) = chkE (env, cxt, e)
305 :     in
306 :     if TU.isValueType ty
307 :     then ()
308 :     else err (cxt, [
309 :     S "expected value type in print, but found ", TY ty
310 :     ]);
311 :     e'
312 :     end
313 :     val args' = List.map chkArg args
314 :     in
315 :     (AST.S_Print args', env)
316 :     end
317 :     | PT.S_New(strand, args) => let
318 :     (* note that scope has already been checked in chkCtlFlow *)
319 :     val stm = checkStrandCreate (env, cxt, strand, args)
320 :     in
321 :     Env.recordProp (env, Properties.NewStrands);
322 :     (stm, env)
323 :     end
324 : jhr 4480 | PT.S_Stabilize => (* Note: scope validity has already been checked in chkCtlFlow *)
325 :     if Env.inGlobalBlock env
326 :     then (
327 :     Env.recordProp (env, Properties.StabilizeAll);
328 :     (AST.S_StabilizeAll, env))
329 :     else (AST.S_Stabilize, env)
330 : jhr 4317 | PT.S_Die => (
331 :     (* note that scope has already been checked in chkCtlFlow *)
332 :     Env.recordProp (env, Properties.StrandsMayDie);
333 :     (AST.S_Die, env))
334 :     | PT.S_Continue => (* note that scope has already been checked in chkCtlFlow *)
335 :     (AST.S_Continue, env)
336 :     | PT.S_Return e => let
337 :     val eTy = chkE (env, cxt, e)
338 :     in
339 :     case E.currentScope env
340 :     of E.FunctionScope(ty', f) => (case Util.coerceType(ty', eTy)
341 :     of SOME e' => (AST.S_Return e', env)
342 :     | NONE => (
343 :     err (cxt, [
344 :     S "type of return expression does not match return type of function ",
345 :     A f, S "\n",
346 :     S " expected: ", TY ty', S "\n",
347 :     S " found: ", TY(#2 eTy)
348 :     ]);
349 :     bogusStm env)
350 :     (* end case *))
351 :     | _ => (AST.S_Return(#1 eTy), env) (* this error condition has already been reported *)
352 :     (* end case *)
353 :     end
354 :     | PT.S_Decl vd => let
355 :     val (x, x', e) = checkVarDecl (env, cxt, Var.LocalVar, vd)
356 :     in
357 :     E.checkForRedef (env, cxt, x);
358 :     (AST.S_Decl(x', e), E.insertLocal(env, cxt, x, x'))
359 :     end
360 :     | PT.S_Assign({span, tree=x}, rator, e) => (case Env.findVar (env, x)
361 :     of NONE => (
362 :     err (cxt, [S "undefined variable ", A x, S " on lhs of assignment"]);
363 :     bogusStm env)
364 :     | SOME x' => let
365 :     val ([], ty) = Var.typeOf x'
366 :     val eTy = chkE (env, cxt, e)
367 :     fun illegalAssign kind = (
368 :     err (cxt, [
369 :     S "illegal assignment to ", S kind, S " ", A x,
370 :     S " in ", S(E.scopeToString(E.currentScope env))
371 :     ]);
372 :     bogusStm env)
373 :     (* check for assignment to variables that are immutable because of their type *)
374 :     fun chkAssign () = (case Var.monoTypeOf x'
375 :     of (Ty.T_Field _) => illegalAssign "field-valued variable"
376 :     | (Ty.T_Image _) => illegalAssign "image-valued variable"
377 :     | (Ty.T_Kernel _) => illegalAssign "kernel-valued variable"
378 :     | ty => (case rator
379 :     of NONE => let
380 :     (* check for promotion *)
381 :     val (e', ty') = (case Util.coerceType(ty, eTy)
382 :     of SOME e' => (e', ty)
383 :     | NONE => (
384 :     err(cxt, [
385 :     S "type of assigned variable ", A x,
386 :     S " does not match type of rhs\n",
387 :     S " expected: ", TY ty, S "\n",
388 :     S " found: ", TY(#2 eTy)
389 :     ]);
390 :     eTy)
391 :     (* end case *))
392 :     in
393 :     (AST.S_Assign(useVar((#1 cxt, span), x'), e'), env)
394 :     end
395 :     | SOME rator => let
396 :     val x' = useVar((#1 cxt, span), x')
397 :     val e1' = AST.E_Var x'
398 :     val (e2', ty2) = eTy
399 :     val Env.PrimFun ovldList = Env.findFunc (env, rator)
400 : jhr 3431 (* NOTE: is there a potential problem with something like: i += r (where i is int and r is real)?
401 :     * It is okay to promote the rhs type, but not the lhs!
402 :     *)
403 : jhr 4317 val (rhs, _) = CheckExpr.resolveOverload (
404 :     cxt, rator, [ty, ty2], [e1', e2'], ovldList)
405 :     in
406 :     (AST.S_Assign(x', rhs), env)
407 :     end
408 :     (* end case *))
409 :     (* end case *))
410 :     (* check that assignment to global variables is allowed in the current scope *)
411 :     fun chkGlobalAssign () = (case E.currentScope env
412 :     of E.FunctionScope _ => illegalAssign "global variable"
413 :     | E.MethodScope _ => illegalAssign "global variable"
414 :     | E.InitScope => chkAssign()
415 : jhr 4491 | E.StartScope => chkAssign()
416 : jhr 4317 | E.UpdateScope => chkAssign()
417 :     | _ => raise Fail "impossible scope"
418 :     (* end case *))
419 :     in
420 :     (* check that assigning to x' is okay *)
421 :     case Var.kindOf x'
422 :     of Var.BasisVar => illegalAssign "builtin function"
423 :     | Var.ConstVar => illegalAssign "constant variable"
424 :     | Var.InputVar => chkGlobalAssign ()
425 :     | Var.GlobalVar => chkGlobalAssign ()
426 :     | Var.FunVar => illegalAssign "function"
427 :     | Var.FunParam => illegalAssign "function parameter"
428 :     | Var.StrandParam => illegalAssign "strand parameter"
429 :     | Var.IterVar => illegalAssign "iteration variable"
430 :     | _ => chkAssign ()
431 :     (* end case *)
432 :     end
433 :     (* end case *))
434 :     (* end case *))
435 : jhr 3398
436 : jhr 3408 fun check (env, cxt, stm) = (
437 : jhr 4317 chkCtlFlow (cxt, E.currentScope env, stm);
438 :     #1 (chk (env, cxt, stm)))
439 : jhr 3398
440 :     end

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