Annotation of /branches/pure-cfg/src/compiler/high-to-mid/high-to-mid.sml

Parent Directory | Revision Log

---

Revision 649 - (view) (download)

1 :	jhr	280	(* high-to-mid.sml
2 :			*
3 :	jhr	435	* COPYRIGHT (c) 2010 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :	jhr	280	* All rights reserved.
5 :			*
6 :			* Translation from HighIL to MidIL representations.
7 :			*)
8 :
9 :			structure HighToMid : sig
10 :
11 :			val translate : HighIL.program -> MidIL.program
12 :
13 :			end = struct
14 :
15 :			structure SrcIL = HighIL
16 :	jhr	392	structure SrcTy = HighILTypes
17 :	jhr	334	structure SrcOp = HighOps
18 :	jhr	364	structure VTbl = SrcIL.Var.Tbl
19 :	jhr	280	structure DstIL = MidIL
20 :	jhr	391	structure DstTy = MidILTypes
21 :	jhr	334	structure DstOp = MidOps
22 :	jhr	280
23 :	jhr	367	type var_env = DstIL.var VTbl.hash_table
24 :	jhr	364
25 :	jhr	548	fun getRHS x = (case SrcIL.Var.binding x
26 :			of SrcIL.VB_RHS(SrcIL.OP(rator, args)) => (rator, args)
27 :			| _ => raise Fail("expected rhs operator for " ^ SrcIL.Var.toString x)
28 :			(* end case *))
29 :
30 :	jhr	394	fun cvtTy SrcTy.BoolTy = DstTy.BoolTy
31 :			| cvtTy SrcTy.StringTy = DstTy.StringTy
32 :			| cvtTy SrcTy.IntTy = DstTy.intTy
33 :			| cvtTy (SrcTy.TensorTy[]) = DstTy.realTy
34 :			| cvtTy (SrcTy.TensorTy[d]) = DstTy.VecTy d
35 :	jhr	517	(* we replace Kernel and Field operations by 0, so the types are mapped to int *)
36 :			| cvtTy SrcTy.KernelTy = DstTy.intTy
37 :			| cvtTy SrcTy.FieldTy = DstTy.intTy
38 :	jhr	397	| cvtTy ty = raise Fail("unexpected type " ^ SrcTy.toString ty)
39 :	jhr	394
40 :	jhr	364	fun rename (env : var_env, x) = (case VTbl.find env x
41 :	jhr	334	of SOME x' => x'
42 :	jhr	364	| NONE => let
43 :	jhr	548	val dstTy = (case SrcIL.Var.ty x
44 :			of SrcTy.ImageTy _ => (
45 :			(* for variables with image type, we need more detailed information
46 :			* about the image for the MidIL type.
47 :			*)
48 :			case getRHS x
49 :			of (SrcOp.LoadImage v, _) => DstTy.ImageTy v
50 :			| _ => raise Fail "bogus image variable"
51 :			(* end case *))
52 :			| _ => cvtTy(SrcIL.Var.ty x)
53 :			(* end case *))
54 :			val x' = DstIL.Var.new (SrcIL.Var.name x, dstTy)
55 :	jhr	364	in
56 :			VTbl.insert env (x, x');
57 :			x'
58 :			end
59 :	jhr	334	(* end case *))
60 :	jhr	517	handle Fail msg => raise Fail(concat["rename(_, ", SrcIL.Var.toString x, "): ", msg])
61 :
62 :	jhr	367	fun renameList (env, xs) = List.map (fn x => rename(env, x)) xs
63 :	jhr	334
64 :	jhr	280	(* expand the field Inside operator into a image-space test *)
65 :	jhr	517	fun expandInside (env, result, pos, fld) = (case getRHS fld
66 :	jhr	548	of (SrcOp.Field d, [img, h]) => (case (getRHS img, getRHS h)
67 :			of ((SrcOp.LoadImage v, _), (SrcOp.Kernel(h, _), [])) => let
68 :	jhr	546	val pos = rename (env, pos)
69 :			val img = rename (env, img)
70 :	jhr	548	val imgPos = DstIL.Var.new ("x", DstTy.VecTy d)
71 :	jhr	546	val s = Kernel.support h
72 :			in [
73 :	jhr	548	(imgPos, DstIL.OP(DstOp.PosToImgSpace v, [img, pos])),
74 :			(result, DstIL.OP(DstOp.Inside(v, s), [imgPos, img]))
75 :	jhr	546	] end
76 :			| _ => raise Fail "bogus kernel binding"
77 :			(* end case *))
78 :	jhr	517	| _ => raise Fail "bogus field binding"
79 :			(* end case *))
80 :	jhr	280
81 :	jhr	517	fun expandProbe (env, result, fld, pos) = (case getRHS fld
82 :	jhr	548	of (SrcOp.Field _, [img, h]) => (case (getRHS img, getRHS h)
83 :	jhr	517	of ((SrcOp.LoadImage v, _), (SrcOp.Kernel(h, k), _)) => Probe.expand {
84 :			result = result,
85 :			img = rename (env, img),
86 :			v = v, h = h, k = k,
87 :			pos = rename (env, pos)
88 :			}
89 :			| _ => raise Fail "bogus image/kernel binding"
90 :	jhr	358	(* end case *))
91 :	jhr	517	| _ => raise Fail "bogus field binding"
92 :			(* end case *))
93 :	jhr	334
94 :	jhr	392	fun arity (SrcTy.TensorTy[]) = 1
95 :			| arity (SrcTy.TensorTy[d]) = d
96 :	jhr	365	| arity _ = raise Fail "arity"
97 :
98 :	jhr	364	fun expandOp (env, y, rator, args) = let
99 :	jhr	365	fun assign rator' =
100 :	jhr	367	[(y, DstIL.OP(rator', renameList(env, args)))]
101 :	jhr	565	fun cvtToInt rator' = let
102 :			val t = DstIL.Var.new ("t", DstTy.realTy)
103 :			in [
104 :			(t, DstIL.OP(rator', renameList(env, args))),
105 :			(y, DstIL.OP(DstOp.RealToInt 1, [t]))
106 :			] end
107 :	jhr	517	fun dummy () = [(y, DstIL.LIT(Literal.Int 0))]
108 :	jhr	364	in
109 :			case rator
110 :	jhr	365	of SrcOp.Add ty => assign (DstOp.Add(cvtTy ty))
111 :			| SrcOp.Sub ty => assign (DstOp.Sub(cvtTy ty))
112 :			| SrcOp.Mul ty => assign (DstOp.Mul(cvtTy ty))
113 :			| SrcOp.Div ty => assign (DstOp.Div(cvtTy ty))
114 :			| SrcOp.Neg ty => assign (DstOp.Neg(cvtTy ty))
115 :			| SrcOp.LT ty => assign (DstOp.LT(cvtTy ty))
116 :			| SrcOp.LTE ty => assign (DstOp.LTE(cvtTy ty))
117 :			| SrcOp.EQ ty => assign (DstOp.EQ(cvtTy ty))
118 :			| SrcOp.NEQ ty => assign (DstOp.NEQ(cvtTy ty))
119 :			| SrcOp.GT ty => assign (DstOp.GT(cvtTy ty))
120 :			| SrcOp.GTE ty => assign (DstOp.GTE(cvtTy ty))
121 :			| SrcOp.Dot ty => assign (DstOp.Dot(arity ty))
122 :			| SrcOp.Cross => assign DstOp.Cross
123 :			| SrcOp.Norm ty => assign (DstOp.Norm(arity ty))
124 :			| SrcOp.Scale ty => assign (DstOp.Scale(arity ty))
125 :			| SrcOp.InvScale ty => assign (DstOp.InvScale(arity ty))
126 :			| SrcOp.CL => assign DstOp.CL
127 :			| SrcOp.PrincipleEvec ty => assign (DstOp.PrincipleEvec(cvtTy ty))
128 :			| SrcOp.Subscript ty => assign (DstOp.Subscript(cvtTy ty))
129 :			| SrcOp.Max => assign DstOp.Max
130 :			| SrcOp.Min => assign DstOp.Min
131 :			| SrcOp.Sin => assign DstOp.Sin
132 :			| SrcOp.Cos => assign DstOp.Cos
133 :			| SrcOp.Pow => assign DstOp.Pow
134 :			| SrcOp.Not => assign DstOp.Not
135 :			| SrcOp.IntToReal => assign DstOp.IntToReal
136 :	jhr	565	| SrcOp.CeilToInt => cvtToInt (DstOp.Ceiling 1)
137 :			| SrcOp.FloorToInt => cvtToInt (DstOp.Floor 1)
138 :			| SrcOp.RoundToInt => cvtToInt (DstOp.Round 1)
139 :			| SrcOp.TruncToInt => cvtToInt (DstOp.Trunc 1)
140 :	jhr	517	| SrcOp.Kernel _ => dummy()
141 :	jhr	365	| SrcOp.LoadImage info => assign (DstOp.LoadImage info)
142 :	jhr	407	| SrcOp.Inside _ => (case args
143 :	jhr	365	of [pos, fld] => expandInside(env, y, pos, fld)
144 :			(* end case *))
145 :	jhr	649	(* fields are used in the Inside and Probe operations, but are otherwise ignored *)
146 :	jhr	548	| SrcOp.Field _ => dummy()
147 :	jhr	649	| SrcOp.AddField => dummy()
148 :			| SrcOp.ScaleField => dummy()
149 :			| SrcOp.NegField => dummy()
150 :			| SrcOp.DiffField => dummy()
151 :	jhr	407	| SrcOp.Probe _ => (case args
152 :	jhr	365	of [fld, pos] => expandProbe(env, y, fld, pos)
153 :			(* end case *))
154 :	jhr	420	| SrcOp.Input(ty, s) => assign (DstOp.Input(cvtTy ty, s))
155 :			| SrcOp.InputWithDefault(ty, s) => assign (DstOp.InputWithDefault(cvtTy ty, s))
156 :	jhr	365	| _ => raise Fail("unexpected " ^ SrcOp.toString rator)
157 :			(* end case *)
158 :			end
159 :	jhr	314
160 :	jhr	387	(* expand a SrcIL assignment to a list of DstIL assignments *)
161 :	jhr	364	fun expand (env, (y, rhs)) = let
162 :	jhr	397	fun assign rhs = [(rename (env, y), rhs)]
163 :	jhr	364	in
164 :			case rhs
165 :			of SrcIL.VAR x => assign (DstIL.VAR(rename(env, x)))
166 :			| SrcIL.LIT lit => assign (DstIL.LIT lit)
167 :	jhr	397	| SrcIL.OP(SrcOp.Field _, args) => []
168 :			| SrcIL.OP(rator, args) => expandOp (env, rename (env, y), rator, args)
169 :	jhr	367	| SrcIL.CONS args => assign (DstIL.CONS(renameList(env, args)))
170 :	jhr	364	(* end case *)
171 :			end
172 :
173 :			structure Trans = TranslateFn (
174 :			struct
175 :			structure SrcIL = SrcIL
176 :			structure DstIL = DstIL
177 :
178 :			type var_env = var_env
179 :
180 :			val rename = rename
181 :	jhr	613	val renameList = renameList
182 :	jhr	500	val expand = DstIL.CFG.mkBlock o expand
183 :	jhr	364	end)
184 :
185 :	jhr	613	fun translate prog = let
186 :			val prog = Trans.translate prog
187 :	jhr	367	in
188 :	jhr	539	MidILCensus.init prog;
189 :			prog
190 :	jhr	367	end
191 :	jhr	364
192 :	jhr	280	end

---

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