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

SCM Repository

[diderot] Annotation of /branches/vis15/src/compiler/simplify/simplify.sml
ViewVC logotype

Annotation of /branches/vis15/src/compiler/simplify/simplify.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4163 - (view) (download)

1 : jhr 3437 (* simplify.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 : jhr 3468 * Simplify the AST representation. This phase involves the following transformations:
9 :     *
10 :     * - types are simplified by removing meta variables (which will have been resolved)
11 :     *
12 :     * - expressions are simplified to involve a single operation on variables
13 :     *
14 :     * - global reductions are converted to MapReduce statements
15 :     *
16 :     * - other comprehensions and reductions are converted to foreach loops
17 :     *
18 :     * - unreachable code is pruned
19 :     *
20 :     * - negation of literal integers and reals are constant folded
21 : jhr 3437 *)
22 :    
23 :     structure Simplify : sig
24 :    
25 :     val transform : Error.err_stream * AST.program -> Simple.program
26 :    
27 :     end = struct
28 :    
29 :     structure TU = TypeUtil
30 :     structure S = Simple
31 : jhr 3445 structure STy = SimpleTypes
32 :     structure Ty = Types
33 : jhr 3437 structure VMap = Var.Map
34 :    
35 : jhr 3445 (* convert a Types.ty to a SimpleTypes.ty *)
36 :     fun cvtTy ty = (case ty
37 :     of Ty.T_Var(Ty.TV{bind, ...}) => (case !bind
38 :     of NONE => raise Fail "unresolved type variable"
39 :     | SOME ty => cvtTy ty
40 :     (* end case *))
41 :     | Ty.T_Bool => STy.T_Bool
42 :     | Ty.T_Int => STy.T_Int
43 :     | Ty.T_String => STy.T_String
44 :     | Ty.T_Sequence(ty, NONE) => STy.T_Sequence(cvtTy ty, NONE)
45 : jhr 3452 | Ty.T_Sequence(ty, SOME dim) => STy.T_Sequence(cvtTy ty, SOME(TU.monoDim dim))
46 : jhr 3846 | Ty.T_Strand id => STy.T_Strand id
47 : jhr 3445 | Ty.T_Kernel n => STy.T_Kernel(TU.monoDiff n)
48 :     | Ty.T_Tensor shape => STy.T_Tensor(TU.monoShape shape)
49 :     | Ty.T_Image{dim, shape} => STy.T_Image{
50 :     dim = TU.monoDim dim,
51 :     shape = TU.monoShape shape
52 :     }
53 :     | Ty.T_Field{diff, dim, shape} => STy.T_Field{
54 :     diff = TU.monoDiff diff,
55 :     dim = TU.monoDim dim,
56 :     shape = TU.monoShape shape
57 :     }
58 : jhr 4163 | Ty.T_Fun(tys1, ty2) => raise Fail "unexpected T_Fun in Simplify"
59 : jhr 3456 | Ty.T_Error => raise Fail "unexpected T_Error in Simplify"
60 : jhr 3445 (* end case *))
61 : jhr 3437
62 : jhr 3811 fun apiTypeOf x = let
63 :     fun cvtTy STy.T_Bool = APITypes.BoolTy
64 :     | cvtTy STy.T_Int = APITypes.IntTy
65 :     | cvtTy STy.T_String = APITypes.StringTy
66 :     | cvtTy (STy.T_Sequence(ty, len)) = APITypes.SeqTy(cvtTy ty, len)
67 :     | cvtTy (STy.T_Tensor shape) = APITypes.TensorTy shape
68 :     | cvtTy (STy.T_Image{dim, shape}) = APITypes.ImageTy(dim, shape)
69 :     | cvtTy ty = raise Fail "bogus API type"
70 :     in
71 :     cvtTy (SimpleVar.typeOf x)
72 :     end
73 :    
74 : jhr 4117 fun newTemp (ty as STy.T_Image _) = SimpleVar.new ("img", SimpleVar.LocalVar, ty)
75 :     | newTemp ty = SimpleVar.new ("_t", SimpleVar.LocalVar, ty)
76 : jhr 3437
77 : jhr 4163 (* a property to map AST function variables to SimpleAST functions *)
78 :     local
79 :     fun cvt x = let
80 :     val Ty.T_Fun(paramTys, resTy) = Var.monoTypeOf x
81 :     in
82 :     SimpleFunc.new (Var.nameOf x, cvtTy resTy, List.map cvtTy paramTys)
83 :     end
84 :     in
85 :     val {getFn = cvtFunc, ...} = Var.newProp cvt
86 :     end
87 :    
88 : jhr 3456 (* a property to map AST variables to SimpleAST variables *)
89 :     local
90 :     fun cvt x = SimpleVar.new (Var.nameOf x, Var.kindOf x, cvtTy(Var.monoTypeOf x))
91 :     in
92 :     val {getFn = cvtVar, ...} = Var.newProp cvt
93 :     end
94 : jhr 3452
95 : jhr 3456 fun cvtVars xs = List.map cvtVar xs
96 : jhr 3452
97 : jhr 3437 (* make a block out of a list of statements that are in reverse order *)
98 : jhr 3501 fun mkBlock stms = S.Block{props = PropList.newHolder(), code = List.rev stms}
99 : jhr 3437
100 :     (* simplify a statement into a single statement (i.e., a block if it expands
101 :     * into more than one new statement).
102 :     *)
103 : jhr 4113 fun simplifyBlock (errStrm, stm) = mkBlock (simplifyStmt (errStrm, stm, []))
104 : jhr 3437
105 :     (* simplify the statement stm where stms is a reverse-order list of preceeding simplified
106 :     * statements. This function returns a reverse-order list of simplified statements.
107 :     * Note that error reporting is done in the typechecker, but it does not prune unreachable
108 :     * code.
109 :     *)
110 : jhr 3456 and simplifyStmt (errStrm, stm, stms) : S.stmt list = (case stm
111 : jhr 3437 of AST.S_Block body => let
112 : jhr 3456 fun simplify ([], stms) = stms
113 :     | simplify (stm::r, stms) = simplify (r, simplifyStmt (errStrm, stm, stms))
114 : jhr 3437 in
115 : jhr 3456 simplify (body, stms)
116 : jhr 3437 end
117 : jhr 3452 | AST.S_Decl(x, NONE) => let
118 : jhr 3456 val x' = cvtVar x
119 : jhr 3452 in
120 : jhr 3465 S.S_Var(x', NONE) :: stms
121 : jhr 3452 end
122 :     | AST.S_Decl(x, SOME e) => let
123 : jhr 3456 val (stms, e') = simplifyExp (errStrm, e, stms)
124 :     val x' = cvtVar x
125 : jhr 3437 in
126 : jhr 3465 S.S_Var(x', SOME e') :: stms
127 : jhr 3437 end
128 :     | AST.S_IfThenElse(e, s1, s2) => let
129 : jhr 3456 val (stms, x) = simplifyExpToVar (errStrm, e, stms)
130 : jhr 4113 val s1 = simplifyBlock (errStrm, s1)
131 :     val s2 = simplifyBlock (errStrm, s2)
132 : jhr 3437 in
133 : jhr 3456 S.S_IfThenElse(x, s1, s2) :: stms
134 : jhr 3437 end
135 : jhr 3456 | AST.S_Foreach((x, e), body) => let
136 :     val (stms, xs') = simplifyExpToVar (errStrm, e, stms)
137 : jhr 4113 val body' = simplifyBlock (errStrm, body)
138 : jhr 3456 in
139 :     S.S_Foreach(cvtVar x, xs', body') :: stms
140 :     end
141 : jhr 3452 | AST.S_Assign((x, _), e) => let
142 : jhr 3456 val (stms, e') = simplifyExp (errStrm, e, stms)
143 : jhr 3437 in
144 : jhr 3456 S.S_Assign(cvtVar x, e') :: stms
145 : jhr 3437 end
146 :     | AST.S_New(name, args) => let
147 : jhr 3456 val (stms, xs) = simplifyExpsToVars (errStrm, args, stms)
148 : jhr 3437 in
149 : jhr 3456 S.S_New(name, xs) :: stms
150 : jhr 3437 end
151 : jhr 3456 | AST.S_Continue => S.S_Continue :: stms
152 :     | AST.S_Die => S.S_Die :: stms
153 :     | AST.S_Stabilize => S.S_Stabilize :: stms
154 : jhr 3437 | AST.S_Return e => let
155 : jhr 3456 val (stms, x) = simplifyExpToVar (errStrm, e, stms)
156 : jhr 3437 in
157 : jhr 3456 S.S_Return x :: stms
158 : jhr 3437 end
159 :     | AST.S_Print args => let
160 : jhr 3456 val (stms, xs) = simplifyExpsToVars (errStrm, args, stms)
161 : jhr 3437 in
162 : jhr 3456 S.S_Print xs :: stms
163 : jhr 3437 end
164 :     (* end case *))
165 :    
166 : jhr 3456 and simplifyExp (errStrm, exp, stms) = let
167 : jhr 3452 fun doPrimApply (f, tyArgs, args, ty) = let
168 : jhr 3456 val (stms, xs) = simplifyExpsToVars (errStrm, args, stms)
169 : jhr 3437 in
170 :     case Var.kindOf f
171 : jhr 3452 of Var.BasisVar => let
172 : jhr 3437 fun cvtTyArg (Types.TYPE tv) = S.TY(cvtTy(TU.resolve tv))
173 :     | cvtTyArg (Types.DIFF dv) = S.DIFF(TU.monoDiff(TU.resolveDiff dv))
174 :     | cvtTyArg (Types.SHAPE sv) = S.SHAPE(TU.monoShape(TU.resolveShape sv))
175 :     | cvtTyArg (Types.DIM dv) = S.DIM(TU.monoDim(TU.resolveDim dv))
176 :     val tyArgs = List.map cvtTyArg tyArgs
177 :     in
178 :     (stms, S.E_Prim(f, tyArgs, xs, cvtTy ty))
179 :     end
180 : jhr 3452 | _ => raise Fail "bogus prim application"
181 : jhr 3437 (* end case *)
182 :     end
183 :     in
184 :     case exp
185 : jhr 3452 of AST.E_Var(x, _) => (case Var.kindOf x
186 : jhr 3437 of Var.BasisVar => let
187 :     val ty = cvtTy(Var.monoTypeOf x)
188 :     val x' = newTemp ty
189 : jhr 3465 val stm = S.S_Var(x', SOME(S.E_Prim(x, [], [], ty)))
190 : jhr 3437 in
191 :     (stm::stms, S.E_Var x')
192 :     end
193 : jhr 3456 | _ => (stms, S.E_Var(cvtVar x))
194 : jhr 3437 (* end case *))
195 :     | AST.E_Lit lit => (stms, S.E_Lit lit)
196 : jhr 4043 | AST.E_Kernel h => (stms, S.E_Kernel h)
197 : jhr 3456 | AST.E_Select(e, (fld, _)) => let
198 :     val (stms, x) = simplifyExpToVar (errStrm, e, stms)
199 :     in
200 :     (stms, S.E_Select(x, cvtVar fld))
201 :     end
202 : jhr 3464 | AST.E_Prim(rator, tyArgs, args as [e], ty) => (case e
203 :     of AST.E_Lit(Literal.Int n) => if Var.same(BasisVars.neg_i, rator)
204 :     then (stms, S.E_Lit(Literal.Int(~n))) (* constant-fold negation of integer literals *)
205 :     else doPrimApply (rator, tyArgs, args, ty)
206 :     | AST.E_Lit(Literal.Real f) =>
207 :     if Var.same(BasisVars.neg_t, rator)
208 :     then (stms, S.E_Lit(Literal.Real(RealLit.negate f))) (* constant-fold negation of real literals *)
209 :     else doPrimApply (rator, tyArgs, args, ty)
210 :     | AST.E_Comprehension(e', (x, e''), seqTy) => if Basis.isReductionOp rator
211 :     then let
212 :     val {rator, init, mvs} = Util.reductionInfo rator
213 :     val (stms, xs) = simplifyExpToVar (errStrm, e'', stms)
214 :     val (bodyStms, bodyResult) = simplifyExpToVar (errStrm, e, [])
215 :     val acc = SimpleVar.new ("accum", Var.LocalVar, cvtTy ty)
216 :     val seqTy' as STy.T_Sequence(elemTy, NONE) = cvtTy seqTy
217 : jhr 3465 val initStm = S.S_Var(acc, SOME(S.E_Lit init))
218 : jhr 3464 val updateStm = S.S_Assign(acc,
219 :     S.E_Prim(rator, mvs, [acc, bodyResult], seqTy'))
220 :     val foreachStm = S.S_Foreach(cvtVar x, xs, mkBlock(updateStm :: bodyStms))
221 :     in
222 :     (foreachStm :: initStm :: stms, S.E_Var acc)
223 :     end
224 :     else doPrimApply (rator, tyArgs, args, ty)
225 :     | AST.E_ParallelMap(e', x, xs, _) =>
226 :     if Basis.isReductionOp rator
227 : jhr 3465 then let
228 :     (* parallel map-reduce *)
229 :     val result = SimpleVar.new ("res", Var.LocalVar, cvtTy ty)
230 :     val (bodyStms, bodyResult) = simplifyExpToVar (errStrm, e', [])
231 :     val (func, args) = Util.makeFunction(
232 :     Var.nameOf rator, mkBlock(S.S_Return bodyResult :: bodyStms),
233 :     SimpleVar.typeOf bodyResult)
234 :     val mapReduceStm = S.S_MapReduce{
235 :     results = [result],
236 :     reductions = [rator],
237 :     body = func,
238 :     args = args,
239 :     source = xs
240 :     }
241 :     in
242 :     (mapReduceStm :: stms, S.E_Var result)
243 :     end
244 : jhr 3464 else raise Fail "unsupported operation on parallel map"
245 :     | _ => doPrimApply (rator, tyArgs, args, ty)
246 :     (* end case *))
247 : jhr 3452 | AST.E_Prim(f, tyArgs, args, ty) => doPrimApply (f, tyArgs, args, ty)
248 :     | AST.E_Apply((f, _), args, ty) => let
249 : jhr 3456 val (stms, xs) = simplifyExpsToVars (errStrm, args, stms)
250 : jhr 3452 in
251 :     case Var.kindOf f
252 : jhr 4163 of Var.FunVar => (stms, S.E_Apply(SimpleFunc.use(cvtFunc f), xs))
253 : jhr 3452 | _ => raise Fail "bogus application"
254 :     (* end case *)
255 :     end
256 : jhr 3464 | AST.E_Comprehension(e, (x, e'), seqTy) => let
257 :     (* convert a comprehension to a foreach loop over the sequence defined by e' *)
258 :     val (stms, xs) = simplifyExpToVar (errStrm, e', stms)
259 :     val (bodyStms, bodyResult) = simplifyExpToVar (errStrm, e, [])
260 :     val seqTy' as STy.T_Sequence(elemTy, NONE) = cvtTy seqTy
261 :     val acc = SimpleVar.new ("accum", Var.LocalVar, seqTy')
262 : jhr 3465 val initStm = S.S_Var(acc, SOME(S.E_Seq([], seqTy')))
263 : jhr 3464 val updateStm = S.S_Assign(acc,
264 :     S.E_Prim(BasisVars.at_dT, [S.TY elemTy], [acc, bodyResult], seqTy'))
265 :     val foreachStm = S.S_Foreach(cvtVar x, xs, mkBlock(updateStm :: bodyStms))
266 :     in
267 :     (foreachStm :: initStm :: stms, S.E_Var acc)
268 :     end
269 : jhr 3467 | AST.E_ParallelMap(e, x, xs, ty) => raise Fail "FIXME: ParallelMap"
270 : jhr 3452 | AST.E_Tensor(es, ty) => let
271 : jhr 3456 val (stms, xs) = simplifyExpsToVars (errStrm, es, stms)
272 : jhr 3437 in
273 : jhr 3452 (stms, S.E_Tensor(xs, cvtTy ty))
274 : jhr 3437 end
275 :     | AST.E_Seq(es, ty) => let
276 : jhr 3456 val (stms, xs) = simplifyExpsToVars (errStrm, es, stms)
277 : jhr 3437 in
278 :     (stms, S.E_Seq(xs, cvtTy ty))
279 :     end
280 :     | AST.E_Slice(e, indices, ty) => let (* tensor slicing *)
281 : jhr 3456 val (stms, x) = simplifyExpToVar (errStrm, e, stms)
282 : jhr 3797 fun f NONE = NONE
283 :     | f (SOME(AST.E_Lit(Literal.Int i))) = SOME(Int.fromLarge i)
284 :     | f _ = raise Fail "expected integer literal in slice"
285 :     val indices = List.map f indices
286 : jhr 3437 in
287 :     (stms, S.E_Slice(x, indices, cvtTy ty))
288 :     end
289 :     | AST.E_Cond(e1, e2, e3, ty) => let
290 :     (* a conditional expression gets turned into an if-then-else statememt *)
291 :     val result = newTemp(cvtTy ty)
292 : jhr 3465 val (stms, x) = simplifyExpToVar (errStrm, e1, S.S_Var(result, NONE) :: stms)
293 : jhr 3437 fun simplifyBranch e = let
294 : jhr 3456 val (stms, e) = simplifyExp (errStrm, e, [])
295 : jhr 3437 in
296 :     mkBlock (S.S_Assign(result, e)::stms)
297 :     end
298 :     val s1 = simplifyBranch e2
299 :     val s2 = simplifyBranch e3
300 :     in
301 :     (S.S_IfThenElse(x, s1, s2) :: stms, S.E_Var result)
302 :     end
303 :     | AST.E_LoadNrrd(_, nrrd, ty) => (case cvtTy ty
304 : jhr 3452 of ty as SimpleTypes.T_Sequence(_, NONE) => (stms, S.E_LoadSeq(ty, nrrd))
305 : jhr 3437 | ty as SimpleTypes.T_Image{dim, shape} => (
306 : jhr 4083 case NrrdInfo.getInfo (errStrm, nrrd)
307 :     of SOME info => (case ImageInfo.fromNrrd(info, dim, shape)
308 :     of NONE => (
309 :     Error.error (errStrm, [
310 :     "nrrd file \"", nrrd, "\" does not have expected type"
311 :     ]);
312 :     (stms, S.E_LoadImage(ty, nrrd, ImageInfo.mkInfo(dim, shape))))
313 :     | SOME info => (stms, S.E_LoadImage(ty, nrrd, info))
314 :     (* end case *))
315 :     | NONE => (
316 :     Error.warning (errStrm, [
317 :     "nrrd file \"", nrrd, "\" does not exist"
318 :     ]);
319 :     (stms, S.E_LoadImage(ty, nrrd, ImageInfo.mkInfo(dim, shape))))
320 : jhr 3437 (* end case *))
321 :     | _ => raise Fail "bogus type for E_LoadNrrd"
322 :     (* end case *))
323 : jhr 3976 | AST.E_Coerce{dstTy, e=AST.E_Lit(Literal.Int n), ...} => (case cvtTy dstTy
324 :     of SimpleTypes.T_Tensor[] => (stms, S.E_Lit(Literal.Real(RealLit.fromInt n)))
325 :     | _ => raise Fail "impossible: bad coercion"
326 :     (* end case *))
327 : jhr 3437 | AST.E_Coerce{srcTy, dstTy, e} => let
328 : jhr 3456 val (stms, x) = simplifyExpToVar (errStrm, e, stms)
329 : jhr 3437 val dstTy = cvtTy dstTy
330 :     val result = newTemp dstTy
331 :     val rhs = S.E_Coerce{srcTy = cvtTy srcTy, dstTy = dstTy, x = x}
332 :     in
333 : jhr 3465 (S.S_Var(result, SOME rhs)::stms, S.E_Var result)
334 : jhr 3437 end
335 :     (* end case *)
336 :     end
337 :    
338 : jhr 3456 and simplifyExpToVar (errStrm, exp, stms) = let
339 :     val (stms, e) = simplifyExp (errStrm, exp, stms)
340 : jhr 3437 in
341 :     case e
342 :     of S.E_Var x => (stms, x)
343 :     | _ => let
344 :     val x = newTemp (S.typeOf e)
345 :     in
346 : jhr 3465 (S.S_Var(x, SOME e)::stms, x)
347 : jhr 3437 end
348 :     (* end case *)
349 :     end
350 :    
351 : jhr 3456 and simplifyExpsToVars (errStrm, exps, stms) = let
352 : jhr 3437 fun f ([], xs, stms) = (stms, List.rev xs)
353 :     | f (e::es, xs, stms) = let
354 : jhr 3456 val (stms, x) = simplifyExpToVar (errStrm, e, stms)
355 : jhr 3437 in
356 :     f (es, x::xs, stms)
357 :     end
358 :     in
359 :     f (exps, [], stms)
360 :     end
361 :    
362 : jhr 4113 (* simplify a block and then prune unreachable and dead code *)
363 :     fun simplifyAndPruneBlock errStrm blk =
364 :     DeadCode.eliminate (simplifyBlock (errStrm, blk))
365 :    
366 : jhr 3995 fun simplifyStrand (errStrm, strand) = let
367 :     val AST.Strand{name, params, state, stateInit, initM, updateM, stabilizeM} = strand
368 : jhr 3456 val params' = cvtVars params
369 :     fun simplifyState ([], xs, stms) = (List.rev xs, mkBlock stms)
370 :     | simplifyState ((x, optE) :: r, xs, stms) = let
371 :     val x' = cvtVar x
372 : jhr 3452 in
373 :     case optE
374 : jhr 3456 of NONE => simplifyState (r, x'::xs, stms)
375 : jhr 3452 | SOME e => let
376 : jhr 3456 val (stms, e') = simplifyExp (errStrm, e, stms)
377 : jhr 3452 in
378 : jhr 3469 simplifyState (r, x'::xs, S.S_Assign(x', e') :: stms)
379 : jhr 3452 end
380 :     (* end case *)
381 :     end
382 : jhr 3456 val (xs, stm) = simplifyState (state, [], [])
383 : jhr 3437 in
384 : jhr 3452 S.Strand{
385 :     name = name,
386 :     params = params',
387 : jhr 3456 state = xs,
388 :     stateInit = stm,
389 : jhr 4113 initM = Option.map (simplifyAndPruneBlock errStrm) initM,
390 :     updateM = simplifyAndPruneBlock errStrm updateM,
391 :     stabilizeM = Option.map (simplifyAndPruneBlock errStrm) stabilizeM
392 : jhr 3452 }
393 : jhr 3437 end
394 :    
395 : jhr 3452 fun transform (errStrm, prog) = let
396 :     val AST.Program{
397 : jhr 3995 props, const_dcls, input_dcls, globals, globInit, strand, create, init, update
398 : jhr 3452 } = prog
399 : jhr 3456 val consts' = ref[]
400 :     val constInit = ref[]
401 : jhr 3452 val inputs' = ref[]
402 :     val globals' = ref[]
403 :     val globalInit = ref[]
404 :     val funcs = ref[]
405 : jhr 3456 fun simplifyConstDcl (x, SOME e) = let
406 :     val (stms, e') = simplifyExp (errStrm, e, [])
407 :     val x' = cvtVar x
408 : jhr 3452 in
409 : jhr 3456 consts' := x' :: !consts';
410 :     constInit := S.S_Assign(x', e') :: (stms @ !constInit)
411 :     end
412 :     fun simplifyInputDcl ((x, NONE), desc) = let
413 :     val x' = cvtVar x
414 :     val init = (case SimpleVar.typeOf x'
415 : jhr 3811 of STy.T_Image{dim, shape} => let
416 : jhr 3456 val info = ImageInfo.mkInfo(dim, shape)
417 :     in
418 :     S.Image info
419 :     end
420 :     | _ => S.NoDefault
421 :     (* end case *))
422 :     val inp = S.INP{
423 :     var = x',
424 : jhr 3504 name = Var.nameOf x,
425 : jhr 3811 ty = apiTypeOf x',
426 : jhr 3456 desc = desc,
427 :     init = init
428 :     }
429 :     in
430 :     inputs' := inp :: !inputs'
431 :     end
432 :     | simplifyInputDcl ((x, SOME(AST.E_LoadNrrd(tvs, nrrd, ty))), desc) = let
433 :     val x' = cvtVar x
434 :     val init = (case SimpleVar.typeOf x'
435 :     of SimpleTypes.T_Sequence(_, NONE) => S.LoadSeq nrrd
436 : jhr 4083 | SimpleTypes.T_Image{dim, shape} => (
437 :     case NrrdInfo.getInfo (errStrm, nrrd)
438 :     of SOME info => (case ImageInfo.fromNrrd(info, dim, shape)
439 :     of NONE => (
440 :     Error.error (errStrm, [
441 :     "proxy nrrd file \"", nrrd,
442 :     "\" does not have expected type"
443 :     ]);
444 :     S.Image(ImageInfo.mkInfo(dim, shape)))
445 :     | SOME info => S.Proxy(nrrd, info)
446 :     (* end case *))
447 :     | NONE => (
448 :     Error.warning (errStrm, [
449 :     "proxy nrrd file \"", nrrd, "\" does not exist"
450 :     ]);
451 :     S.Image(ImageInfo.mkInfo(dim, shape)))
452 :     (* end case *))
453 : jhr 3456 | _ => raise Fail "impossible"
454 :     (* end case *))
455 :     val inp = S.INP{
456 :     var = x',
457 : jhr 3504 name = Var.nameOf x,
458 : jhr 3811 ty = apiTypeOf x',
459 : jhr 3456 desc = desc,
460 :     init = init
461 :     }
462 :     in
463 :     inputs' := inp :: !inputs'
464 :     end
465 :     | simplifyInputDcl ((x, SOME e), desc) = let
466 :     val x' = cvtVar x
467 :     val (stms, e') = simplifyExp (errStrm, e, [])
468 :     val inp = S.INP{
469 :     var = x',
470 : jhr 3504 name = Var.nameOf x,
471 : jhr 3811 ty = apiTypeOf x',
472 : jhr 3456 desc = desc,
473 :     init = S.ConstExpr
474 :     }
475 :     in
476 :     inputs' := inp :: !inputs';
477 :     constInit := S.S_Assign(x', e') :: (stms @ !constInit)
478 :     end
479 :     fun simplifyGlobalDcl (AST.D_Var(x, optE)) = let
480 :     val x' = cvtVar x
481 :     in
482 : jhr 3452 case optE
483 : jhr 3456 of NONE => globals' := x' :: !globals'
484 : jhr 3452 | SOME e => let
485 : jhr 3456 val (stms, e') = simplifyExp (errStrm, e, [])
486 : jhr 3452 in
487 :     globals' := x' :: !globals';
488 : jhr 3456 globalInit := S.S_Assign(x', e') :: (stms @ !globalInit)
489 : jhr 3452 end
490 :     (* end case *)
491 :     end
492 : jhr 3456 | simplifyGlobalDcl (AST.D_Func(f, params, body)) = let
493 : jhr 4163 val f' = cvtFunc f
494 : jhr 3456 val params' = cvtVars params
495 : jhr 4113 val body' = simplifyAndPruneBlock errStrm body
496 : jhr 3452 in
497 : jhr 3456 funcs := S.Func{f=f', params=params', body=body'} :: !funcs
498 : jhr 3452 end
499 : jhr 3995 val () = (
500 :     List.app simplifyConstDcl const_dcls;
501 :     List.app simplifyInputDcl input_dcls;
502 :     List.app simplifyGlobalDcl globals)
503 :     (* make the global-initialization block *)
504 :     val globInit = (case globInit
505 :     of SOME stm => mkBlock (simplifyStmt (errStrm, stm, !globalInit))
506 :     | NONE => mkBlock (!globalInit)
507 :     (* end case *))
508 : jhr 4130 (* if the globInit block is non-empty, record the fact in the property list *)
509 :     val props = (case globInit
510 :     of S.Block{code=[], ...} => props
511 :     | _ => Properties.GlobalInit :: props
512 :     (* end case *))
513 : jhr 3452 in
514 :     S.Program{
515 :     props = props,
516 : jhr 3456 consts = List.rev(!consts'),
517 : jhr 3452 inputs = List.rev(!inputs'),
518 : jhr 3456 constInit = mkBlock (!constInit),
519 : jhr 3452 globals = List.rev(!globals'),
520 : jhr 3995 globInit = globInit,
521 : jhr 3452 funcs = List.rev(!funcs),
522 : jhr 3456 strand = simplifyStrand (errStrm, strand),
523 : jhr 4113 create = Create.map (simplifyAndPruneBlock errStrm) create,
524 :     init = Option.map (simplifyAndPruneBlock errStrm) init,
525 :     update = Option.map (simplifyAndPruneBlock errStrm) update
526 : jhr 3452 }
527 :     end
528 :    
529 : jhr 3437 end

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