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

SCM Repository

[diderot] Annotation of /branches/pure-cfg/src/compiler/c-target/c-target.sml
ViewVC logotype

Annotation of /branches/pure-cfg/src/compiler/c-target/c-target.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 732 - (view) (download)

1 : jhr 519 (* c-target.sml
2 :     *
3 :     * COPYRIGHT (c) 2011 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 :     * All rights reserved.
5 :     *
6 :     * Generate C code with SSE 4.2 intrinsics.
7 :     *)
8 :    
9 :     structure CTarget : TARGET =
10 :     struct
11 :    
12 : jhr 522 structure CL = CLang
13 : jhr 551 structure RN = RuntimeNames
14 : jhr 522
15 : jhr 551 datatype ty = datatype TargetTy.ty
16 : jhr 519
17 : jhr 623 datatype var = V of (ty * string)
18 :    
19 :     datatype exp = E of CLang.exp * ty
20 :    
21 :     type stm = CL.stm
22 :    
23 : jhr 544 datatype strand = Strand of {
24 :     name : string,
25 :     tyName : string,
26 : jhr 623 state : var list ref,
27 : jhr 654 output : var option ref, (* the strand's output variable (only one for now) *)
28 : jhr 544 code : CL.decl list ref
29 :     }
30 : jhr 525
31 : jhr 527 datatype program = Prog of {
32 :     globals : CL.decl list ref,
33 : jhr 533 topDecls : CL.decl list ref,
34 : jhr 624 strands : strand AtomTable.hash_table,
35 :     initially : CL.decl ref
36 : jhr 527 }
37 :    
38 : jhr 519 (* for SSE, we have 128-bit vectors *)
39 : jhr 551 fun vectorWidth () = !RN.gVectorWid
40 : jhr 519
41 :     (* target types *)
42 : jhr 525 val boolTy = T_Bool
43 :     val intTy = T_Int
44 :     val realTy = T_Real
45 :     fun vecTy 1 = T_Real
46 : jhr 551 | vecTy n = if (n < 1) orelse (!RN.gVectorWid < n)
47 : jhr 525 then raise Size
48 :     else T_Vec n
49 :     fun ivecTy 1 = T_Int
50 : jhr 551 | ivecTy n = if (n < 1) orelse (!RN.gVectorWid < n)
51 : jhr 525 then raise Size
52 :     else T_IVec n
53 : jhr 548 fun imageTy (ImageInfo.ImgInfo{ty=([], rTy), dim, ...}) = T_Image(dim, rTy)
54 :     fun imageDataTy (ImageInfo.ImgInfo{ty=([], rTy), ...}) = T_Ptr rTy
55 : jhr 534 val stringTy = T_String
56 : jhr 519
57 : jhr 552 val statusTy = CL.T_Named RN.statusTy
58 : jhr 534
59 : jhr 528 (* convert target types to CLang types *)
60 :     fun cvtTy T_Bool = CLang.T_Named "bool"
61 : jhr 534 | cvtTy T_String = CL.charPtr
62 : jhr 551 | cvtTy T_Int = !RN.gIntTy
63 :     | cvtTy T_Real = !RN.gRealTy
64 : jhr 561 | cvtTy (T_Vec n) = CL.T_Named(RN.vecTy n)
65 :     | cvtTy (T_IVec n) = CL.T_Named(RN.ivecTy n)
66 : jhr 683 | cvtTy (T_Mat(n,m)) = CL.T_Named(RN.matTy(n,m))
67 : jhr 561 | cvtTy (T_Image(n, _)) = CL.T_Ptr(CL.T_Named(RN.imageTy n))
68 : jhr 548 | cvtTy (T_Ptr ty) = CL.T_Ptr(CL.T_Num ty)
69 : jhr 528
70 : jhr 548 (* report invalid arguments *)
71 :     fun invalid (name, []) = raise Fail("invaild "^name)
72 :     | invalid (name, args) = let
73 : jhr 623 fun arg2s (E(e, ty)) = concat["(", CL.expToString e, " : ", TargetTy.toString ty, ")"]
74 : jhr 548 val args = String.concatWith ", " (List.map arg2s args)
75 :     in
76 :     raise Fail(concat["invalid arguments to ", name, ": ", args])
77 :     end
78 :    
79 : jhr 525 (* helper functions for checking the types of arguments *)
80 :     fun scalarTy T_Int = true
81 :     | scalarTy T_Real = true
82 :     | scalarTy _ = false
83 : jhr 548 fun numTy T_Int = true
84 :     | numTy T_Real = true
85 :     | numTy (T_Vec _) = true
86 :     | numTy (T_IVec _) = true
87 :     | numTy _ = false
88 : jhr 519
89 : jhr 528 fun newProgram () = (
90 : jhr 551 RN.initTargetSpec();
91 : jhr 528 Prog{
92 : jhr 554 globals = ref [
93 :     CL.D_Verbatim[
94 :     if !Controls.doublePrecision
95 :     then "#define DIDEROT_DOUBLE_PRECISION"
96 :     else "#define DIDEROT_SINGLE_PRECISION",
97 :     "#include \"Diderot/diderot.h\""
98 :     ]],
99 : jhr 533 topDecls = ref [],
100 : jhr 624 strands = AtomTable.mkTable (16, Fail "strand table"),
101 :     initially = ref(CL.D_Comment["missing initially"])
102 : jhr 528 })
103 :    
104 : jhr 618 (* register the global initialization part of a program *)
105 : jhr 533 fun globalInit (Prog{topDecls, ...}, init) = let
106 : jhr 551 val initFn = CL.D_Func([], CL.voidTy, RN.initGlobals, [], init)
107 : jhr 533 in
108 :     topDecls := initFn :: !topDecls
109 :     end
110 :    
111 : jhr 623 (* create and register the initially function for a program *)
112 :     fun initially {
113 : jhr 624 prog = Prog{strands, initially, ...},
114 : jhr 623 isArray : bool,
115 : jhr 624 iterPrefix : stm,
116 : jhr 623 iters : (var * exp * exp) list,
117 : jhr 624 createPrefix : stm,
118 :     strand : Atom.atom,
119 : jhr 623 args : exp list
120 :     } = let
121 : jhr 624 val iterPrefix = (case iterPrefix
122 :     of CL.S_Block stms => stms
123 :     | stm => [stm]
124 :     (* end case *))
125 :     val createPrefix = (case createPrefix
126 :     of CL.S_Block stms => stms
127 :     | stm => [stm]
128 :     (* end case *))
129 :     val name = Atom.toString strand
130 : jhr 623 val nDims = List.length iters
131 :     val worldTy = CL.T_Ptr(CL.T_Named RN.worldTy)
132 :     fun mapi f xs = let
133 :     fun mapf (_, []) = []
134 :     | mapf (i, x::xs) = f(i, x) :: mapf(i+1, xs)
135 :     in
136 :     mapf (0, xs)
137 :     end
138 :     val baseInit = mapi (fn (i, (_, E(e, _), _)) => (i, CL.I_Exp e)) iters
139 :     val sizeInit = mapi
140 :     (fn (i, (V(ty, _), E(lo, _), E(hi, _))) =>
141 :     (i, CL.I_Exp(CL.mkBinOp(CL.mkBinOp(hi, CL.#-, lo), CL.#+, CL.E_Int(1, cvtTy ty))))
142 :     ) iters
143 :     val allocCode = [
144 :     CL.S_Comment["allocate initial block of strands"],
145 :     CL.S_Decl(CL.T_Array(CL.int32, SOME nDims), "base", SOME(CL.I_Array baseInit)),
146 :     CL.S_Decl(CL.T_Array(CL.uint32, SOME nDims), "size", SOME(CL.I_Array sizeInit)),
147 :     CL.S_Decl(worldTy, "wrld",
148 :     SOME(CL.I_Exp(CL.E_Apply(RN.allocInitially, [
149 :     CL.mkUnOp(CL.%&, CL.E_Var(RN.strandDesc name)),
150 :     CL.E_Bool isArray,
151 :     CL.E_Int(IntInf.fromInt nDims, CL.int32),
152 :     CL.E_Var "base",
153 :     CL.E_Var "size"
154 :     ]))))
155 :     ]
156 :     (* create the loop nest for the initially iterations *)
157 :     val indexVar = "ix"
158 : jhr 634 val strandTy = CL.T_Ptr(CL.T_Named(RN.strandTy name))
159 : jhr 623 fun mkLoopNest [] = CL.mkBlock(createPrefix @ [
160 : jhr 634 CL.S_Decl(strandTy, "sp",
161 :     SOME(CL.I_Exp(
162 :     CL.E_Cast(strandTy,
163 :     CL.E_Apply(RN.inState, [CL.E_Var "wrld", CL.E_Var indexVar]))))),
164 : jhr 624 CL.S_Call(RN.strandInit name, CL.E_Var "sp" :: List.map (fn (E(e, _)) => e) args),
165 :     CL.S_Assign(CL.E_Var indexVar, CL.mkBinOp(CL.E_Var indexVar, CL.#+, CL.E_Int(1, CL.uint32)))
166 : jhr 623 ])
167 :     | mkLoopNest ((V(ty, param), E(lo,_), E(hi, _))::iters) = let
168 :     val body = mkLoopNest iters
169 :     in
170 :     CL.S_For(
171 :     [(cvtTy ty, param, lo)],
172 :     CL.mkBinOp(CL.E_Var param, CL.#<=, hi),
173 :     [CL.mkPostOp(CL.E_Var param, CL.^++)],
174 :     body)
175 :     end
176 :     val iterCode = [
177 :     CL.S_Comment["initially"],
178 :     CL.S_Decl(CL.uint32, indexVar, SOME(CL.I_Exp(CL.E_Int(0, CL.uint32)))),
179 :     mkLoopNest iters
180 :     ]
181 :     val body = CL.mkBlock(iterPrefix @ allocCode @ iterCode @ [CL.S_Return(SOME(CL.E_Var "wrld"))])
182 :     val initFn = CL.D_Func([], worldTy, RN.initially, [], body)
183 : jhr 618 in
184 : jhr 624 initially := initFn
185 : jhr 618 end
186 :    
187 : jhr 525 structure Var =
188 :     struct
189 : jhr 528 fun global (Prog{globals, ...}, ty, name) = (
190 : jhr 573 globals := CL.D_Var([], cvtTy ty, name, NONE) :: !globals;
191 : jhr 623 V(ty, name))
192 :     fun param (ty, name) = V(ty, name)
193 : jhr 544 fun state (Strand{state, ...}, ty, name) = (
194 : jhr 623 state := V(ty, name) :: !state;
195 :     V(ty, name))
196 :     fun var (ty, name) = V(ty, name)
197 : jhr 554 local
198 :     val count = ref 0
199 :     fun freshName prefix = let
200 :     val n = !count
201 :     in
202 :     count := n+1;
203 :     concat[prefix, "_", Int.toString n]
204 :     end
205 :     in
206 : jhr 623 fun tmp ty = V(ty, freshName "tmp")
207 : jhr 554 fun fresh prefix = freshName prefix
208 :     end (* local *)
209 : jhr 519 end
210 :    
211 :     (* expression construction *)
212 : jhr 525 structure Expr =
213 :     struct
214 : jhr 549 (* return true if the given expression from is allowed as a subexpression *)
215 :     fun allowedInline _ = true (* FIXME *)
216 :    
217 : jhr 519 (* variable references *)
218 : jhr 623 fun global (V(ty, x)) = E(CL.mkVar x, ty)
219 :     fun getState (V(ty, x)) = E(CL.mkIndirect(CL.mkVar "selfIn", x), ty)
220 :     fun param (V(ty, x)) = E(CL.mkVar x, ty)
221 :     fun var (V(ty, x)) = E(CL.mkVar x, ty)
222 : jhr 525
223 : jhr 519 (* literals *)
224 : jhr 623 fun intLit n = E(CL.mkInt(n, !RN.gIntTy), intTy)
225 :     fun floatLit f = E(CL.mkFlt(f, !RN.gRealTy), realTy)
226 :     fun stringLit s = E(CL.mkStr s, stringTy)
227 :     fun boolLit b = E(CL.mkBool b, boolTy)
228 : jhr 525
229 : jhr 561 (* select from a vector. We have to cast to the corresponding union type and then
230 :     * select from the array field.
231 :     *)
232 :     local
233 :     fun sel (tyCode, field, ty) (i, e, n) =
234 :     if (i < 0) orelse (n <= i)
235 :     then raise Subscript
236 :     else let
237 :     val unionTy = CL.T_Named(concat["union", Int.toString n, !tyCode, "_t"])
238 :     val e1 = CL.mkCast(unionTy, e)
239 :     val e2 = CL.mkSelect(e1, field)
240 :     in
241 : jhr 623 E(CL.mkSubscript(e2, CL.mkInt(IntInf.fromInt i, CL.int32)), ty)
242 : jhr 561 end
243 :     val selF = sel (RN.gRealSuffix, "r", T_Real)
244 :     val selI = sel (RN.gIntSuffix, "i", T_Int)
245 :     in
246 : jhr 654 fun ivecIndex (e, d, i) = let val E(e', _) = selI(i, e, d) in e' end
247 :     fun vecIndex (e, d, i) = let val E(e', _) = selF(i, e, d) in e' end
248 : jhr 623 fun select (i, E(e, T_Vec n)) = selF (i, e, n)
249 :     | select (i, E(e, T_IVec n)) = selI (i, e, n)
250 : jhr 548 | select (_, x) = invalid("select", [x])
251 : jhr 561 end (* local *)
252 : jhr 525
253 : jhr 705 fun subscript (E(e1, ty), E(e2, T_Int)) = let
254 :     val (n, tyCode, elemTy) = (case ty
255 :     of T_Vec n => (n, !RN.gRealSuffix, T_Real)
256 :     | T_IVec n => (n, !RN.gIntSuffix, T_Int)
257 :     (* end case *))
258 :     val unionTy = CL.T_Named(concat["union", Int.toString n, tyCode, "_t"])
259 : jhr 732 val vecExp = CL.mkSelect(CL.mkCast(unionTy, e1), "r")
260 : jhr 705 in
261 : jhr 732 E(CL.mkSubscript(vecExp, e2), elemTy)
262 : jhr 705 end
263 :    
264 : jhr 519 (* vector (and scalar) arithmetic *)
265 : jhr 525 local
266 :     fun checkTys (ty1, ty2) = (ty1 = ty2) andalso numTy ty1
267 : jhr 623 fun binop rator (E(e1, ty1), E(e2, ty2)) =
268 : jhr 525 if checkTys (ty1, ty2)
269 : jhr 623 then E(CL.mkBinOp(e1, rator, e2), ty1)
270 : jhr 548 else invalid (
271 :     concat["binary operator \"", CL.binopToString rator, "\""],
272 : jhr 623 [E(e1, ty1), E(e2, ty2)])
273 : jhr 525 in
274 : jhr 623 fun add (E(e1, ty as T_Ptr _), E(e2, T_Int)) = E(CL.mkBinOp(e1, CL.#+, e2), ty)
275 : jhr 548 | add args = binop CL.#+ args
276 : jhr 623 fun sub (E(e1, ty as T_Ptr _), E(e2, T_Int)) = E(CL.mkBinOp(e1, CL.#-, e2), ty)
277 : jhr 548 | sub args = binop CL.#- args
278 : jhr 544 (* NOTE: multiplication and division are also used for scaling *)
279 : jhr 623 fun mul (E(e1, T_Real), E(e2, T_Vec n)) =
280 :     E(CL.E_Apply(RN.scale n, [e1, e2]), T_Vec n)
281 : jhr 544 | mul args = binop CL.#* args
282 : jhr 623 fun divide (E(e1, T_Vec n), E(e2, T_Real)) = let
283 :     val E(one, _) = floatLit FloatLit.one
284 :     in
285 :     E(CL.E_Apply(RN.scale n, [CL.mkBinOp(one, CL.#/, e2), e1]), T_Vec n)
286 :     end
287 : jhr 544 | divide args = binop CL.#/ args
288 : jhr 525 end (* local *)
289 : jhr 623 fun neg (E(e, T_Bool)) = raise Fail "invalid argument to neg"
290 :     | neg (E(e, ty)) = E(CL.mkUnOp(CL.%-, e), ty)
291 : jhr 525
292 : jhr 623 fun abs (E(e, T_Int)) = E(CL.mkApply("abs", [e]), T_Int) (* FIXME: not the right type for 64-bit ints *)
293 :     | abs (E(e, T_Real)) = E(CL.mkApply("fabs" ^ !RN.gRealSuffix, [e]), T_Real)
294 :     | abs (E(e, T_Vec n)) = raise Fail "FIXME: Expr.abs"
295 :     | abs (E(e, T_IVec n)) = raise Fail "FIXME: Expr.abs"
296 : jhr 525 | abs _ = raise Fail "invalid argument to abs"
297 :    
298 : jhr 623 fun dot (E(e1, T_Vec n1), E(e2, T_Vec n2)) = E(CL.E_Apply(RN.dot n1, [e1, e2]), T_Real)
299 : jhr 525 | dot _ = raise Fail "invalid argument to dot"
300 :    
301 : jhr 623 fun cross (E(e1, T_Vec 3), E(e2, T_Vec 3)) = E(CL.E_Apply(RN.cross(), [e1, e2]), T_Vec 3)
302 : jhr 525 | cross _ = raise Fail "invalid argument to cross"
303 :    
304 : jhr 623 fun length (E(e, T_Vec n)) = E(CL.E_Apply(RN.length n, [e]), T_Real)
305 : jhr 525 | length _ = raise Fail "invalid argument to length"
306 :    
307 : jhr 623 fun normalize (E(e, T_Vec n)) = E(CL.E_Apply(RN.normalize n, [e]), T_Vec n)
308 : jhr 525 | normalize _ = raise Fail "invalid argument to length"
309 :    
310 : jhr 683 (* matrix operations *)
311 :     fun trace (E(e, T_Mat(n,m))) = if (n = m) andalso (1 < n) andalso (m <= 4)
312 :     then E(CL.E_Apply(RN.trace n, [e]), T_Real)
313 :     else raise Fail "invalid matrix argument for trace"
314 :     | trace _ = raise Fail "invalid argument to trace"
315 :    
316 : jhr 519 (* comparisons *)
317 : jhr 525 local
318 :     fun checkTys (ty1, ty2) =
319 :     (ty1 = ty2) andalso scalarTy ty1
320 : jhr 623 fun cmpop rator (E(e1, ty1), E(e2, ty2)) =
321 : jhr 525 if checkTys (ty1, ty2)
322 : jhr 623 then E(CL.mkBinOp(e1, rator, e2), T_Bool)
323 : jhr 548 else invalid (
324 :     concat["compare operator \"", CL.binopToString rator, "\""],
325 : jhr 623 [E(e1, ty1), E(e2, ty2)])
326 : jhr 525 in
327 :     val lt = cmpop CL.#<
328 :     val lte = cmpop CL.#<=
329 :     val equ = cmpop CL.#==
330 :     val neq = cmpop CL.#!=
331 :     val gte = cmpop CL.#>=
332 :     val gt = cmpop CL.#>
333 :     end (* local *)
334 :    
335 : jhr 519 (* logical connectives *)
336 : jhr 623 fun not (E(e, T_Bool)) = E(CL.mkUnOp(CL.%!, e), T_Bool)
337 : jhr 525 | not _ = raise Fail "invalid argument to not"
338 : jhr 623 fun && (E(e1, T_Bool), E(e2, T_Bool)) = E(CL.mkBinOp(e1, CL.#&&, e2), T_Bool)
339 : jhr 525 | && _ = raise Fail "invalid arguments to &&"
340 : jhr 623 fun || (E(e1, T_Bool), E(e2, T_Bool)) = E(CL.mkBinOp(e1, CL.#||, e2), T_Bool)
341 : jhr 525 | || _ = raise Fail "invalid arguments to ||"
342 :    
343 :     local
344 :     fun checkTys (ty1, ty2) = (ty1 = ty2) andalso scalarTy ty1
345 : jhr 623 fun binFn f (E(e1, ty1), E(e2, ty2)) =
346 : jhr 525 if checkTys (ty1, ty2)
347 : jhr 623 then E(CL.mkApply(f ty1, [e1, e2]), ty1)
348 : jhr 525 else raise Fail "invalid arguments to binary function"
349 :     in
350 : jhr 519 (* misc functions *)
351 : jhr 561 val min = binFn RN.min
352 :     val max = binFn RN.max
353 : jhr 525 end (* local *)
354 :    
355 : jhr 551 (* rounding *)
356 : jhr 623 fun trunc (E(e, ty)) = E(CL.mkApply(RN.addTySuffix("trunc", ty), [e]), ty)
357 :     fun round (E(e, ty)) = E(CL.mkApply(RN.addTySuffix("round", ty), [e]), ty)
358 :     fun floor (E(e, ty)) = E(CL.mkApply(RN.addTySuffix("floor", ty), [e]), ty)
359 :     fun ceil (E(e, ty)) = E(CL.mkApply(RN.addTySuffix("ceil", ty), [e]), ty)
360 : jhr 551
361 : jhr 519 (* conversions *)
362 : jhr 623 fun toInt (E(e, T_Real)) = E(CL.mkCast(!RN.gIntTy, e), T_Int)
363 :     | toInt (E(e, T_Vec n)) = E(CL.mkApply(RN.vecftoi n, [e]), ivecTy n)
364 : jhr 565 | toInt e = invalid ("toInt", [e])
365 : jhr 623 fun toReal (E(e, T_Int)) = E(CL.mkCast(!RN.gRealTy, e), T_Real)
366 : jhr 548 | toReal e = invalid ("toReal", [e])
367 : jhr 525
368 : jhr 519 (* runtime system hooks *)
369 : jhr 623 fun imageAddr (E(e, T_Image(_, rTy))) = let
370 : jhr 561 val cTy = CL.T_Ptr(CL.T_Num rTy)
371 : jhr 528 in
372 : jhr 623 E(CL.mkCast(cTy, CL.mkIndirect(e, "data")), T_Ptr rTy)
373 : jhr 528 end
374 : jhr 548 | imageAddr a = invalid("imageAddr", [a])
375 : jhr 623 fun getImgData (E(e, T_Ptr rTy)) = let
376 : jhr 551 val realTy as CL.T_Num rTy' = !RN.gRealTy
377 : jhr 548 val e = CL.E_UnOp(CL.%*, e)
378 :     in
379 :     if (rTy' = rTy)
380 : jhr 623 then E(e, T_Real)
381 :     else E(CL.E_Cast(realTy, e), T_Real)
382 : jhr 548 end
383 :     | getImgData a = invalid("getImgData", [a])
384 : jhr 623 fun posToImgSpace (E(img, T_Image(d, _)), E(pos, T_Vec n)) = let
385 : jhr 551 val e = CL.mkApply(RN.toImageSpace d, [img, pos])
386 : jhr 548 in
387 : jhr 623 E(e, T_Vec n)
388 : jhr 548 end
389 :     | posToImgSpace (a, b) = invalid("posToImgSpace", [a, b])
390 : jhr 623 fun inside (E(pos, T_Vec n), E(img, T_Image(d, _)), s) = let
391 : jhr 551 val e = CL.mkApply(RN.inside d,
392 : jhr 576 [pos, img, CL.mkInt(IntInf.fromInt s, CL.int32)])
393 : jhr 547 in
394 : jhr 623 E(e, T_Bool)
395 : jhr 547 end
396 : jhr 548 | inside (a, b, _) = invalid("inside", [a, b])
397 : jhr 519
398 : jhr 695 (* other basis functions *)
399 :     local
400 :     val basis = [
401 :     (ILBasis.atan2, fn [E(e1, T_Real), E(e2, T_Real)] => SOME[e1, e2] | _ => NONE, T_Real),
402 :     (ILBasis.cos, fn [E(e, T_Real)] => SOME[e] | _ => NONE, T_Real),
403 :     (ILBasis.pow, fn [E(e1, T_Real), E(e2, T_Real)] => SOME[e1, e2] | _ => NONE, T_Real),
404 :     (ILBasis.sin, fn [E(e, T_Real)] => SOME[e] | _ => NONE, T_Real),
405 :     (ILBasis.sqrt, fn [E(e, T_Real)] => SOME[e] | _ => NONE, T_Real),
406 :     (ILBasis.tan, fn [E(e, T_Real)] => SOME[e] | _ => NONE, T_Real)
407 :     ]
408 :     fun mkLookup suffix = let
409 :     val tbl = ILBasis.Tbl.mkTable (16, Fail "basis table")
410 :     fun ins (f, chkTy, resTy) =
411 :     ILBasis.Tbl.insert tbl
412 :     (f, (ILBasis.toString f ^ suffix, chkTy, resTy))
413 :     in
414 :     List.app ins basis;
415 :     ILBasis.Tbl.lookup tbl
416 :     end
417 :     val fLookup = mkLookup "f"
418 :     val dLookup = mkLookup ""
419 :     in
420 :     fun apply (f, args) = let
421 :     val (f', chkArgs, resTy) = if !Controls.doublePrecision then dLookup f else fLookup f
422 :     in
423 :     case chkArgs args
424 :     of SOME args => E(CL.mkApply(f', args), resTy)
425 :     | NONE => raise Fail("invalid arguments for "^ILBasis.toString f)
426 :     end
427 :     end (* local *)
428 : jhr 547 end (* Expr *)
429 :    
430 : jhr 519 (* statement construction *)
431 : jhr 525 structure Stmt =
432 :     struct
433 :     val comment = CL.S_Comment
434 : jhr 623 fun assignState (V(_, x), E(e, _)) =
435 : jhr 547 CL.mkAssign(CL.mkIndirect(CL.mkVar "selfOut", x), e)
436 : jhr 623 fun assign (V(_, x), E(e, _)) = CL.mkAssign(CL.mkVar x, e)
437 :     fun decl (V(ty, x), SOME(E(e, _))) = CL.mkDecl(cvtTy ty, x, SOME(CL.I_Exp e))
438 :     | decl (V(ty, x), NONE) = CL.mkDecl(cvtTy ty, x, NONE)
439 : jhr 525 val block = CL.mkBlock
440 : jhr 623 fun ifthen (E(e, T_Bool), s1) = CL.mkIfThen(e, s1)
441 :     fun ifthenelse (E(e, T_Bool), s1, s2) = CL.mkIfThenElse(e, s1, s2)
442 :     fun for (V(ty, x), E(lo, _), E(hi, _), body) = CL.mkFor(
443 : jhr 617 [(cvtTy ty, x, lo)],
444 :     CL.mkBinOp(CL.mkVar x, CL.#<=, hi),
445 :     [CL.mkPostOp(CL.mkVar x, CL.^++)],
446 :     body)
447 : jhr 534 (* special Diderot forms *)
448 : jhr 623 fun cons (V(T_Vec n, x), args : exp list) =
449 :     CL.mkAssign(CL.mkVar x, CL.mkApply(RN.mkVec n, List.map (fn E(e, _) => e) args))
450 : jhr 553 | cons _ = raise Fail "bogus cons"
451 : jhr 623 fun getImgData (V(T_Vec n, x), E(e, T_Ptr rTy)) = let
452 : jhr 554 val addr = Var.fresh "vp"
453 : jhr 561 val needsCast = (CL.T_Num rTy <> !RN.gRealTy)
454 :     fun mkLoad i = let
455 :     val e = CL.mkSubscript(CL.mkVar addr, CL.mkInt(IntInf.fromInt i, CL.int32))
456 :     in
457 :     if needsCast then CL.mkCast(!RN.gRealTy, e) else e
458 :     end
459 : jhr 554 in [
460 : jhr 623 CL.mkDecl(CL.T_Ptr(CL.T_Num rTy), addr, SOME(CL.I_Exp e)),
461 : jhr 561 CL.mkAssign(CL.mkVar x,
462 :     CL.mkApply(RN.mkVec n, List.tabulate (n, mkLoad)))
463 : jhr 554 ] end
464 :     | getImgData _ = raise Fail "bogus getImgData"
465 :     local
466 :     fun checkSts mkDecl = let
467 :     val sts = Var.fresh "sts"
468 :     in
469 :     mkDecl sts @
470 :     [CL.mkIfThen(
471 :     CL.mkBinOp(CL.mkVar "DIDEROT_OK", CL.#!=, CL.mkVar sts),
472 :     CL.mkCall("exit", [CL.mkInt(1, CL.int32)]))]
473 :     end
474 :     in
475 : jhr 623 fun loadImage (V(_, lhs), dim, E(name, _)) = checkSts (fn sts => let
476 : jhr 551 val imgTy = CL.T_Named(RN.imageTy dim)
477 :     val loadFn = RN.loadImage dim
478 : jhr 534 in [
479 :     CL.S_Decl(
480 :     statusTy, sts,
481 : jhr 623 SOME(CL.I_Exp(CL.E_Apply(loadFn, [name, CL.mkUnOp(CL.%&, CL.E_Var lhs)]))))
482 : jhr 554 ] end)
483 : jhr 623 fun input (V(ty, lhs), name, optDflt) = checkSts (fn sts => let
484 :     val inputFn = RN.input ty
485 :     val lhs = CL.E_Var lhs
486 : jhr 534 val (initCode, hasDflt) = (case optDflt
487 : jhr 623 of SOME(E(e, _)) => ([CL.S_Assign(lhs, e)], true)
488 : jhr 534 | NONE => ([], false)
489 :     (* end case *))
490 :     val code = [
491 :     CL.S_Decl(
492 :     statusTy, sts,
493 : jhr 623 SOME(CL.I_Exp(CL.E_Apply(inputFn, [
494 : jhr 534 CL.E_Str name, CL.mkUnOp(CL.%&, lhs), CL.mkBool hasDflt
495 : jhr 623 ]))))
496 : jhr 534 ]
497 :     in
498 :     initCode @ code
499 : jhr 554 end)
500 :     end (* local *)
501 : jhr 564 fun exit () = CL.mkReturn NONE
502 :     fun active () = CL.mkReturn(SOME(CL.mkVar RN.kActive))
503 :     fun stabilize () = CL.mkReturn(SOME(CL.mkVar RN.kStabilize))
504 : jhr 562 fun die () = CL.mkReturn(SOME(CL.mkVar RN.kDie))
505 : jhr 519 end
506 :    
507 : jhr 544 structure Strand =
508 :     struct
509 :     fun define (Prog{strands, ...}, strandId) = let
510 : jhr 624 val name = Atom.toString strandId
511 : jhr 544 val strand = Strand{
512 : jhr 624 name = name,
513 :     tyName = RN.strandTy name,
514 : jhr 544 state = ref [],
515 : jhr 654 output = ref NONE,
516 : jhr 544 code = ref []
517 :     }
518 :     in
519 : jhr 624 AtomTable.insert strands (strandId, strand);
520 : jhr 544 strand
521 :     end
522 :    
523 : jhr 624 (* return the strand with the given name *)
524 :     fun lookup (Prog{strands, ...}, strandId) = AtomTable.lookup strands strandId
525 :    
526 : jhr 544 (* register the strand-state initialization code. The variables are the strand
527 :     * parameters.
528 :     *)
529 :     fun init (Strand{name, tyName, code, ...}, params, init) = let
530 : jhr 551 val fName = RN.strandInit name
531 : jhr 544 val params =
532 : jhr 547 CL.PARAM([], CL.T_Ptr(CL.T_Named tyName), "selfOut") ::
533 : jhr 623 List.map (fn (V(ty, x)) => CL.PARAM([], cvtTy ty, x)) params
534 : jhr 544 val initFn = CL.D_Func([], CL.voidTy, fName, params, init)
535 :     in
536 :     code := initFn :: !code
537 :     end
538 : jhr 547
539 :     (* register a strand method *)
540 :     fun method (Strand{name, tyName, code, ...}, methName, body) = let
541 :     val fName = concat[name, "_", methName]
542 :     val params = [
543 :     CL.PARAM([], CL.T_Ptr(CL.T_Named tyName), "selfIn"),
544 :     CL.PARAM([], CL.T_Ptr(CL.T_Named tyName), "selfOut")
545 :     ]
546 : jhr 654 val methFn = CL.D_Func(["static"], CL.int32, fName, params, body)
547 : jhr 547 in
548 :     code := methFn :: !code
549 :     end
550 : jhr 654
551 :     fun output (Strand{output, ...}, x) = (case !output
552 :     of NONE => output := SOME x
553 :     | _ => raise Fail "multiple outputs are not supported yet"
554 :     (* end case *))
555 : jhr 544 end (* Strand *)
556 :    
557 : jhr 654 fun genStrand (Strand{name, tyName, state, output, code}) = let
558 : jhr 624 (* the type declaration for the strand's state struct *)
559 : jhr 544 val selfTyDef = CL.D_StructDef(
560 : jhr 623 List.rev (List.map (fn V(ty, x) => (cvtTy ty, x)) (!state)),
561 : jhr 544 tyName)
562 : jhr 654 (* the print function *)
563 :     val prFnName = concat[name, "_print"]
564 :     val prFn = let
565 :     val params = [
566 :     CL.PARAM([], CL.T_Ptr(CL.T_Named "FILE"), "outS"),
567 :     CL.PARAM([], CL.T_Ptr(CL.T_Named tyName), "self")
568 :     ]
569 :     val SOME(V(ty, x)) = !output
570 :     val outState = CL.mkIndirect(CL.mkVar "self", x)
571 :     val prArgs = (case ty
572 :     of TargetTy.T_Int => [CL.E_Str(!RN.gIntFormat ^ "\n"), outState]
573 :     | TargetTy.T_Real => [CL.E_Str "%f\n", outState]
574 :     | TargetTy.T_Vec d => let
575 :     val fmt = CL.E_Str(
576 :     String.concatWith " " (List.tabulate(d, fn _ => "%f"))
577 :     ^ "\n")
578 : jhr 656 val args = List.tabulate (d, fn i => Expr.vecIndex(outState, d, i))
579 : jhr 654 in
580 :     fmt :: args
581 :     end
582 :     | TargetTy.T_IVec d => let
583 :     val fmt = CL.E_Str(
584 :     String.concatWith " " (List.tabulate(d, fn _ => !RN.gIntFormat))
585 :     ^ "\n")
586 : jhr 656 val args = List.tabulate (d, fn i => Expr.ivecIndex(outState, d, i))
587 : jhr 654 in
588 :     fmt :: args
589 :     end
590 :     | _ => raise Fail("genStrand: unsupported output type " ^ TargetTy.toString ty)
591 :     (* end case *))
592 :     in
593 :     CL.D_Func(["static"], CL.voidTy, prFnName, params,
594 :     CL.S_Call("fprintf", CL.mkVar "outS" :: prArgs))
595 :     end
596 : jhr 624 (* the strand's descriptor object *)
597 :     val descI = let
598 : jhr 573 fun fnPtr (ty, f) = CL.I_Exp(CL.mkCast(CL.T_Named ty, CL.mkVar f))
599 :     in
600 :     CL.I_Struct[
601 :     ("name", CL.I_Exp(CL.E_Str name)),
602 :     ("stateSzb", CL.I_Exp(CL.mkSizeof(CL.T_Named(RN.strandTy name)))),
603 : jhr 654 ("update", fnPtr("update_method_t", name ^ "_update")),
604 :     ("print", fnPtr("print_method_t", prFnName))
605 : jhr 573 ]
606 :     end
607 : jhr 624 val desc = CL.D_Var([], CL.T_Named RN.strandDescTy, RN.strandDesc name, SOME descI)
608 :     in
609 : jhr 654 selfTyDef :: List.rev (desc :: prFn :: !code)
610 : jhr 624 end
611 :    
612 :     (* generate the table of strand descriptors *)
613 :     fun genStrandTable (ppStrm, strands) = let
614 :     val nStrands = length strands
615 :     fun genInit (Strand{name, ...}) = CL.I_Exp(CL.mkUnOp(CL.%&, CL.E_Var(RN.strandDesc name)))
616 : jhr 573 fun genInits (_, []) = []
617 :     | genInits (i, s::ss) = (i, genInit s) :: genInits(i+1, ss)
618 :     fun ppDecl dcl = PrintAsC.output(ppStrm, dcl)
619 :     in
620 :     ppDecl (CL.D_Var([], CL.int32, RN.numStrands,
621 :     SOME(CL.I_Exp(CL.E_Int(IntInf.fromInt nStrands, CL.int32)))));
622 : jhr 624 ppDecl (CL.D_Var([],
623 :     CL.T_Array(CL.T_Ptr(CL.T_Named RN.strandDescTy), SOME nStrands),
624 :     RN.strands,
625 : jhr 573 SOME(CL.I_Array(genInits (0, strands)))))
626 :     end
627 :    
628 : jhr 731 fun genSrc (baseName, Prog{globals, topDecls, strands, initially}) = let
629 : jhr 527 val fileName = OS.Path.joinBaseExt{base=baseName, ext=SOME "c"}
630 :     val outS = TextIO.openOut fileName
631 :     val ppStrm = PrintAsC.new outS
632 : jhr 533 fun ppDecl dcl = PrintAsC.output(ppStrm, dcl)
633 : jhr 624 val strands = AtomTable.listItems strands
634 : jhr 527 in
635 : jhr 533 List.app ppDecl (List.rev (!globals));
636 :     List.app ppDecl (List.rev (!topDecls));
637 : jhr 624 List.app (fn strand => List.app ppDecl (genStrand strand)) strands;
638 :     genStrandTable (ppStrm, strands);
639 :     ppDecl (!initially);
640 : jhr 527 PrintAsC.close ppStrm;
641 :     TextIO.closeOut outS
642 :     end
643 :    
644 : jhr 731 (* FIXME: control flags that should go somewhere else *)
645 :     val debug = ref false
646 :     val verbose = ref true
647 :    
648 :     fun system cmd = (
649 :     if !verbose
650 :     then print(cmd ^ "\n")
651 :     else ();
652 :     if OS.Process.isSuccess(OS.Process.system cmd)
653 :     then ()
654 :     else raise Fail "error compiling/linking")
655 :    
656 :     fun compile baseName = let
657 :     val cFile = OS.Path.joinBaseExt{base=baseName, ext=SOME"c"}
658 :     val cflags = if !debug
659 :     then Paths.cflags
660 :     else String.concatWith " " ["-NDEBUG", Paths.cflags]
661 :     val cmd = String.concatWith " " [
662 :     Paths.cc, "-c", cflags,
663 :     "-I" ^ Paths.diderotInclude, "-I" ^ Paths.teemInclude,
664 :     cFile
665 :     ]
666 :     in
667 :     system cmd
668 :     end
669 :    
670 :     fun link baseName = let
671 :     val objFile = OS.Path.joinBaseExt{base=baseName, ext=SOME"o"}
672 :     val exeFile = baseName
673 :     val cmd = String.concatWith " " [
674 :     Paths.cc, "-o", exeFile, objFile,
675 :     "-L" ^ Paths.teemLib, "-lteem",
676 :     OS.Path.concat(Paths.diderotLib, "diderot-lib.o")
677 :     ]
678 :     in
679 :     system cmd
680 :     end
681 :    
682 :     fun generate (baseName, prog) = (
683 :     genSrc (baseName, prog);
684 :     compile baseName;
685 :     link baseName)
686 :    
687 : jhr 519 end
688 :    
689 :     structure CBackEnd = CodeGenFn(CTarget)

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