Diff of /branches/vis15/src/compiler/simplify/util.sml

Parent Directory | Revision Log | Patch

	revision 3464, Sun Nov 29 17:38:34 2015 UTC	revision 3465, Sun Nov 29 20:04:16 2015 UTC
#	Line 17	Line 17
17	mvs : SimpleTypes.meta_arg list     (* meta-variable arguments for primitive application *)	mvs : SimpleTypes.meta_arg list     (* meta-variable arguments for primitive application *)
18	}	}
19
20		(* convert a block into a function by closing over its free variables *)
21		val makeFunction : string * Simple.block * SimpleTypes.ty -> Simple.func * Simple.var list
22
23	end = struct	end = struct
24
25		structure S = Simple
26	structure BV = BasisVars	structure BV = BasisVars
27	structure L = Literal	structure L = Literal
28	structure R = RealLit	structure R = RealLit
29		structure VMap = SimpleVar.Map
30
31	fun reductionInfo rator =	fun reductionInfo rator =
32	if Var.same(BV.red_all, rator)	if Var.same(BV.red_all, rator)
#	Line 42	Line 47
47	then raise Fail "FIXME: 'variance' reduction not yet supported"	then raise Fail "FIXME: 'variance' reduction not yet supported"
48	else raise Fail(Var.uniqueNameOf rator ^ " is not a reduction operator")	else raise Fail(Var.uniqueNameOf rator ^ " is not a reduction operator")
49
50		local
51		val n = ref 0
52		fun mkFuncId (name, ty) = let val id = !n
53		in
54		n := id + 1;
55		SimpleVar.new(name ^ Int.toString id, SimpleVar.FunVar, ty)
56		end
57		in
58		fun makeFunction (name, blk, resTy) = let
59		val freeVars = ref []
60		fun cvtVar (env, x) = (case VMap.find(env, x)
61		of SOME x' => (env, x')
62		| NONE => let
63		val x' = SimpleVar.copy(x, SimpleVar.FunParam)
64		in
65		freeVars := (x, x') :: !freeVars;
66		(VMap.insert(env, x, x'), x')
67		end
68		(* end case *))
69		fun cvtVars (env, xs) = let
70		fun cvt (x, (env, xs')) = let
71		val (env, x') = cvtVar (env, x)
72		in
73		(env, x'::xs')
74		end
75		in
76		List.foldr cvt (env, []) xs
77		end
78		fun newVar (env, x) = let
79		val x' = SimpleVar.copy(x, SimpleVar.LocalVar)
80		in
81		(VMap.insert(env, x, x'), x')
82		end
83		fun cvtBlock (env, S.Block stms) = let
84		fun cvtStms (env, [], stms') = (env, S.Block(List.rev stms'))
85		| cvtStms (env, stm::stms, stms') = let
86		val (env, stm') = cvtStm (env, stm)
87		in
88		cvtStms (env, stms, stm'::stms')
89		end
90		in
91		cvtStms (env, stms, [])
92		end
93		and cvtStm (env, stm) = (case stm
94		of S.S_Var(x, NONE) => let
95		val (env, x') = newVar (env, x)
96		in
97		(env, S.S_Var(x', NONE))
98		end
99		| S.S_Var(x, SOME e) => let
100		val (env, e') = cvtExp (env, e)
101		val (env, x') = newVar (env, x)
102		in
103		(env, S.S_Var(x', SOME e'))
104		end
105		| S.S_Assign(x, e) => let
106		val (env, e') = cvtExp (env, e)
107		val (env, x') = cvtVar (env, x)
108		in
109		(env, S.S_Assign(x', e'))
110		end
111		| S.S_IfThenElse(x, b1, b2) => let
112		val (env, x') = cvtVar (env, x)
113		val (env, b1') = cvtBlock (env, b1)
114		val (env, b2') = cvtBlock (env, b2)
115		in
116		(env, S.S_IfThenElse(x', b1', b2'))
117		end
118		| S.S_Foreach(x, xs, b) => let
119		val (env, x') = cvtVar (env, x)
120		val (env, xs') = cvtVar (env, xs)
121		val (env, b') = cvtBlock (env, b)
122		in
123		(env, S.S_Foreach(x', xs', b'))
124		end
125		| S.S_New(name, args) => let
126		val (env, args') = cvtVars (env, args)
127		in
128		(env, S.S_New(name, args'))
129		end
130		| S.S_Continue => (env, stm)
131		| S.S_Die => (env, stm)
132		| S.S_Stabilize => (env, stm)
133		| S.S_Return x => let
134		val (env, x') = cvtVar (env, x)
135		in
136		(env, S.S_Return x')
137		end
138		| S.S_Print xs => let
139		val (env, xs') = cvtVars (env, xs)
140		in
141		(env, S.S_Print xs')
142		end
143		| S.S_MapReduce _ => raise Fail "unexpected nested MapReduce"
144		(* end case *))
145		and cvtExp (env, exp) = (case exp
146		of S.E_Var x => let
147		val (env, x') = cvtVar (env, x)
148		in
149		(env, S.E_Var x')
150		end
151		| S.E_Lit _ => (env, exp)
152		| S.E_Select(x, fld) => let
153		val (env, x') = cvtVar (env, x)
154		in
155		(env, S.E_Select(x', fld))
156		end
157		| S.E_Apply(f, args, ty) => let
158		val (env, args') = cvtVars (env, args)
159		in
160		(env, S.E_Apply(f, args', ty))
161		end
162		| S.E_Prim(f, mvs, args, ty) => let
163		val (env, args') = cvtVars (env, args)
164		in
165		(env, S.E_Prim(f, mvs, args', ty))
166		end
167		| S.E_Tensor(args, ty) => let
168		val (env, args') = cvtVars (env, args)
169		in
170		(env, S.E_Tensor(args', ty))
171		end
172		| S.E_Seq(args, ty) => let
173		val (env, args') = cvtVars (env, args)
174		in
175		(env, S.E_Seq(args', ty))
176		end
177		| S.E_Slice(x, indices, ty) => let
178		fun cvt (NONE, (env, idxs)) = (env, NONE::idxs)
179		| cvt (SOME x, (env, idxs)) = let
180		val (env, x') = cvtVar (env, x)
181		in
182		(env, SOME x' :: idxs)
183		end
184		val (env, x') = cvtVar (env, x)
185		val (env, indices') = List.foldr cvt (env, []) indices
186		in
187		(env, S.E_Slice(x', indices', ty))
188		end
189		| S.E_Coerce{srcTy, dstTy, x} => let
190		val (env, x') = cvtVar (env, x)
191		in
192		(env, S.E_Coerce{srcTy=srcTy, dstTy=dstTy, x=x'})
193		end
194		| S.E_LoadSeq _ => (env, exp)
195		| S.E_LoadImage _ => (env, exp)
196		(* end case *))
197		val (env, blk) = cvtBlock (VMap.empty, blk)
198		val (args, params) = ListPair.unzip (List.rev (! freeVars))
199		val fnTy = SimpleTypes.T_Fun(List.map SimpleVar.typeOf params, resTy)
200		in
201		(S.Func{f=mkFuncId(name, fnTy), params=params, body=blk}, args)
202		end
203		end (* local *)
204
205	end	end

---

Colored Diff Long Colored Diff Unidiff Context Diff Side by Side

Legend: Removed from v.3464   changed lines   Added in v.3465

---

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