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

SCM Repository

[diderot] Annotation of /branches/vis12/src/compiler/codegen/clang.sml
ViewVC logotype

Annotation of /branches/vis12/src/compiler/codegen/clang.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2708 - (view) (download)

1 : jhr 1115 (* clang.sml
2 :     *
3 : jhr 2708 * COPYRIGHT (c) 2014 The Diderot Project (http://diderot-language.cs.uchicago.edu)
4 : jhr 1115 * All rights reserved.
5 :     *
6 :     * An tree representation of programs in a C-like language (e.g., C, CUDA,
7 :     * or OpenCL). The purpose of this code is to commonality between the various
8 :     * backends, which are all generating C-like code.
9 :     *)
10 :    
11 :     structure CLang =
12 :     struct
13 :    
14 :     type var = string
15 : jhr 1368 type attr = string (* e.g., "static", "kernel", etc ... *)
16 : jhr 1115
17 :     datatype ty
18 :     = T_Num of RawTypes.ty
19 :     | T_Ptr of ty
20 :     | T_Array of ty * int option
21 :     | T_Named of string
22 : jhr 1444 | T_Qual of attr * ty (* qualified type *)
23 : jhr 1115
24 : jhr 1368 datatype typed_var = V of ty * var
25 :    
26 : jhr 1115 val voidTy = T_Named "void"
27 : jhr 2054 val voidPtr = T_Ptr voidTy
28 : jhr 1301 val charTy = T_Named "char"
29 : jhr 1368 val boolTy = T_Named "bool"
30 : jhr 2054 val charPtr = T_Ptr charTy
31 : jhr 2708 val charArrayPtr = T_Ptr charPtr
32 : jhr 1232 val intTy = T_Named "int"
33 : jhr 1716 val int8 = T_Num(RawTypes.RT_Int8)
34 :     val uint8 = T_Num(RawTypes.RT_UInt8)
35 : jhr 1115 val int32 = T_Num(RawTypes.RT_Int32)
36 :     val uint32 = T_Num(RawTypes.RT_UInt32)
37 :     val int64 = T_Num(RawTypes.RT_Int64)
38 :     val float = T_Num(RawTypes.RT_Float)
39 :     val double = T_Num(RawTypes.RT_Double)
40 :    
41 :     datatype decl
42 : jhr 2116 = D_Pragma of string list
43 :     | D_Comment of string list
44 : jhr 1115 (* verbatim text (e.g., preprocessor directives) *)
45 :     | D_Verbatim of string list
46 :     (* global variable declaration *)
47 :     | D_Var of attr list * ty * var * initializer option
48 : jhr 1702 (* function prototype *)
49 :     | D_Proto of attr list * ty * string * param list
50 : jhr 1115 (* function definition *)
51 :     | D_Func of attr list * ty * string * param list * stm
52 : jhr 2684 (* struct type declaration; if the third argument is SOME name, then a
53 : jhr 1716 * typedef is generated.
54 :     *)
55 :     | D_StructDef of string option * (ty * string) list * string option
56 : jhr 1115
57 :     and initializer
58 :     = I_Exp of exp
59 : jhr 2708 | I_Exps of initializer list
60 :     | I_Struct of (string * initializer) list (* C99 labeled struct initializer *)
61 :     | I_Array of (int * initializer) list (* C99 labeled array initializer *)
62 : jhr 1115
63 :     and param = PARAM of attr list * ty * var
64 :    
65 :     and stm
66 : jhr 1368 = S_Block of stm list (* "{" stms "}" *)
67 : jhr 1115 | S_Comment of string list
68 : jhr 2116 | S_Verbatim of string list
69 : jhr 1368 | S_Decl of attr list * ty * var * initializer option
70 :     (* ty var [ '=' exp ]';' *)
71 :     | S_Exp of exp (* exp ';' *)
72 :     | S_If of exp * stm * stm (* 'if' exp stm 'else' stm *)
73 :     | S_While of exp * stm (* 'while' exp stm *)
74 : jhr 1444 | S_DoWhile of stm * exp (* 'do' stm 'while' exp *)
75 : jhr 1115 | S_For of (ty * var * exp) list * exp * exp list * stm
76 : jhr 1368 (* 'for' '(' inits ';' exp ';' incrs ')' stm *)
77 :     | S_Return of exp option (* 'return' [ exp ] ';' *)
78 :     | S_Break (* 'break' ';' *)
79 :     | S_Continue (* 'continue' ';' *)
80 : jhr 1115
81 :     and exp
82 : jhr 1368 = E_Grp of exp (* "(" e ")" *)
83 : jhr 1115 | E_AssignOp of exp * assignop * exp (* lvalue op= e *)
84 : jhr 1640 | E_Cond of exp * exp * exp (* e "?" e ":" e *)
85 : jhr 1368 | E_BinOp of exp * binop * exp (* e op e *)
86 :     | E_UnOp of unop * exp (* op e *)
87 :     | E_PostOp of exp * postfix (* e op *)
88 : jhr 2708 | E_Apply of exp * exp list (* f "(" ... ")" *)
89 : jhr 1368 | E_Subscript of exp * exp (* e "[" e "]" *)
90 :     | E_Select of exp * string (* e "." f *)
91 :     | E_Indirect of exp * string (* e "->" f *)
92 :     | E_Cast of ty * exp (* "(" ty ")" e *)
93 : jhr 1115 | E_Var of var
94 :     | E_Int of IntegerLit.integer * ty
95 :     | E_Flt of FloatLit.float * ty
96 :     | E_Bool of bool
97 :     | E_Str of string
98 : jhr 2708 | E_Char of char
99 : jhr 1368 | E_Sizeof of ty (* "sizeof(" ty ")" *)
100 : jhr 1115
101 :     (* assignment operators *)
102 :     and assignop
103 :     = $= | += | *= | /= | %= | <<= | >>= | &= | ^= | |=
104 :    
105 :     (* binary operators in increasing order of precedence *)
106 :     and binop
107 :     = #||
108 :     | #&&
109 : jhr 1444 | #|
110 :     | #^
111 :     | #&
112 : jhr 1115 | #== | #!=
113 :     | #< | #<= | #>= | #>
114 :     | #<< | #>>
115 :     | #+ | #-
116 :     | #* | #/ | #%
117 :    
118 :     and unop = %- | %! | %& | %* | %~ | %++ | %--
119 :    
120 :     and postfix = ^++ | ^--
121 :    
122 :     (* smart constructors that add E_Grp wrappers based on operator precedence *)
123 :     local
124 : jhr 1368 val commaP = 0
125 :     val assignP = 1
126 :     val condP = 2
127 :     val lorP = 3
128 :     val landP = 4
129 :     val borP = 5
130 : jhr 1444 val bxorP = 6
131 :     val bandP = 7
132 :     val eqP = 8
133 :     val relP = 9
134 :     val shiftP = 10
135 :     val addP = 11
136 :     val mulP = 12
137 :     val castP = 13
138 :     val unaryP = 14
139 :     val preP = 15
140 :     val compundP = 16 (* compound literal *)
141 :     val postP = 17
142 :     val callP = 18
143 :     val subP = 19
144 :     val atomP = 20
145 : jhr 1115 fun precOfBinop rator = (case rator
146 : jhr 1368 of #|| => lorP
147 :     | #&& => landP
148 : jhr 1444 | #| => borP
149 :     | #^ => bxorP
150 :     | #& => bandP
151 : jhr 1368 | #== => eqP | #!= => eqP
152 :     | #< => relP | #<= => relP | #>= => relP | #> => relP
153 :     | #<< => shiftP | #>> => shiftP
154 :     | #+ => addP | #- => addP
155 :     | #* => mulP | #/ => mulP | #% => mulP
156 :     (* end case *))
157 : jhr 1115 fun prec (E_Grp _) = atomP
158 : jhr 1368 | prec (E_AssignOp _) = assignP
159 : jhr 1640 | prec (E_Cond _) = condP
160 : jhr 1368 | prec (E_BinOp(_, rator, _)) = precOfBinop rator
161 :     | prec (E_UnOp _) = preP
162 :     | prec (E_PostOp _) = postP
163 :     | prec (E_Apply _) = callP
164 :     | prec (E_Subscript _) = postP
165 :     | prec (E_Select _) = postP
166 :     | prec (E_Indirect _) = postP
167 : jhr 1444 | prec (E_Cast _) = castP
168 : jhr 1368 | prec (E_Var _) = atomP
169 :     | prec (E_Int _) = atomP
170 :     | prec (E_Flt _) = atomP
171 :     | prec (E_Bool _) = atomP
172 :     | prec (E_Str _) = atomP
173 : jhr 2708 | prec (E_Char _) = atomP
174 : jhr 1368 | prec (E_Sizeof _) = callP
175 : jhr 1115 in
176 :     fun mkGrp e = if (prec e < atomP) then E_Grp e else e
177 :     fun mkAssignOp (e1, rator, e2) = let
178 : jhr 1368 val e1' = if prec e1 < unaryP then E_Grp e1 else e1
179 :     val e2' = if prec e2 < assignP then E_Grp e2 else e2
180 :     in
181 :     E_AssignOp(e1', rator, e2')
182 :     end
183 : jhr 1640 (* note that we over-parenthesize here, but it makes nested conditionals easeier to read *)
184 :     fun mkCond (e1, e2, e3) = E_Cond(
185 :     if prec e1 <= condP then E_Grp e1 else e1,
186 :     if prec e2 <= condP then E_Grp e2 else e2,
187 :     if prec e3 < condP then E_Grp e3 else e3)
188 : jhr 1115 (* Note that all C binary operators are left associative. *)
189 :     fun mkBinOp (e1, #-, e2 as E_UnOp(%-, _)) = let
190 : jhr 1368 val e1' = if prec e1 < addP then E_Grp e1 else e1
191 :     val e2' = E_Grp e2
192 :     in
193 :     E_BinOp(e1', #-, e2')
194 :     end
195 : jhr 1115 | mkBinOp (e1, rator, e2) = let
196 : jhr 1368 val p = precOfBinop rator
197 :     val e1' = if prec e1 < p then E_Grp e1 else e1
198 :     val e2' = if prec e2 <= p then E_Grp e2 else e2
199 :     in
200 :     E_BinOp(e1', rator, e2')
201 :     end
202 : jhr 1115 fun mkUnOp (%-, e as E_UnOp(%-, _)) = E_UnOp(%-, E_Grp e)
203 :     | mkUnOp (%-, e as E_UnOp(%--, _)) = E_UnOp(%-, E_Grp e)
204 :     | mkUnOp (%--, e as E_UnOp(%-, _)) = E_UnOp(%--, E_Grp e)
205 :     | mkUnOp (%--, e as E_UnOp(%--, _)) = E_UnOp(%--, E_Grp e)
206 : jhr 1858 | mkUnOp (%&, E_UnOp(%*, e)) = e
207 :     | mkUnOp (%*, E_UnOp(%&, e)) = e
208 : jhr 1115 | mkUnOp (rator, e) = if prec e < unaryP
209 : jhr 1368 then E_UnOp(rator, E_Grp e)
210 :     else E_UnOp(rator, e)
211 : jhr 1115 fun mkPostOp (e, rator) = if prec e < postP
212 : jhr 1368 then E_PostOp(E_Grp e, rator)
213 :     else E_PostOp(e, rator)
214 : jhr 2708 fun mkApply (f, args) = E_Apply(E_Var f, args)
215 :     fun mkApplyExp (e, args) = E_Apply(e, args)
216 : jhr 1115 fun mkSubscript(e1, e2) = if prec e1 < postP
217 : jhr 1368 then E_Subscript(E_Grp e1, e2)
218 :     else E_Subscript(e1, e2)
219 : jhr 1115 fun mkSelect (e, f) = if prec e < postP
220 : jhr 1368 then E_Select(E_Grp e, f)
221 :     else E_Select(e, f)
222 : jhr 1115 fun mkIndirect (e, f) = if prec e < postP
223 : jhr 1368 then E_Indirect(E_Grp e, f)
224 :     else E_Indirect(e, f)
225 : jhr 1444 fun mkCast (ty, e) = if prec e < castP
226 :     then E_Cast(ty, E_Grp e)
227 :     else E_Cast(ty, e)
228 : jhr 1115 val mkVar = E_Var
229 : jhr 1368 fun mkIntTy (n, ty) = if n < 0 then E_UnOp(%-, E_Int(~n, ty)) else E_Int(n, ty)
230 :     fun mkInt n = mkIntTy(n, intTy)
231 : jhr 1115 fun mkFlt (f, ty) = if FloatLit.isNeg f
232 : jhr 1368 then E_UnOp(%-, E_Flt(FloatLit.negate f, ty))
233 :     else E_Flt(f, ty)
234 : jhr 1115 val mkBool = E_Bool
235 :     val mkStr = E_Str
236 : jhr 2708 val mkChar = E_Char
237 : jhr 1115 val mkSizeof = E_Sizeof
238 : jhr 2708 fun mkAddrOf x = mkUnOp(%&, x)
239 : jhr 1115 end (* local *)
240 :    
241 :     val skip = S_Block[]
242 :    
243 :     local
244 :     fun paren (e as E_Grp _) = e
245 : jhr 1368 | paren e = E_Grp e
246 : jhr 1115 in
247 :     val mkComment = S_Comment
248 :     fun mkBlock [stm] = stm
249 :     | mkBlock stms = S_Block stms
250 : jhr 1806 fun unBlock (S_Block stms) = stms
251 :     | unBlock stm = [stm]
252 : jhr 2051 fun prependStm (stm, blk) = mkBlock(stm :: unBlock blk)
253 :     fun appendStm (blk, stm) = mkBlock(unBlock blk @ [stm])
254 : jhr 2708 fun concatBlocks blocks = mkBlock(List.concat(List.map unBlock blocks))
255 : jhr 1368 fun mkDecl (ty, x, init) = S_Decl([], ty, x, init)
256 : jhr 1715 fun mkDeclInit (ty, x, init) = S_Decl([], ty, x, SOME(I_Exp init))
257 : jhr 1368 val mkAttrDecl = S_Decl
258 : jhr 1115 val mkExpStm = S_Exp
259 :     fun mkAssign (e1, e2) = S_Exp(mkAssignOp(e1, $=, e2))
260 : jhr 2708 fun mkAssign' (e1, rator, e2) = S_Exp(mkAssignOp(e1, rator, e2))
261 : jhr 1115 fun mkIfThenElse (e, b1, b2) = S_If(paren e, b1, b2)
262 :     fun mkIfThen (e, b) = mkIfThenElse (e, b, skip)
263 :     val mkFor = S_For
264 :     fun mkWhile (e, b) = S_While(paren e, b)
265 : jhr 1444 fun mkDoWhile (b, e) = S_DoWhile(b, paren e)
266 : jhr 2708 fun mkCall (f, args) = S_Exp(mkApply(f, args))
267 :     fun mkCallExp (f, args) = S_Exp(mkApplyExp(f, args))
268 : jhr 1115 val mkReturn = S_Return
269 :     val mkBreak = S_Break
270 :     val mkContinue = S_Continue
271 :     end (* local *)
272 :    
273 :     (* utility functions *)
274 :    
275 :     fun varToString x = x
276 :    
277 :     fun assignopToString rator = (case rator
278 : jhr 1368 of $= => "="
279 :     | += => "+="
280 :     | *= => "*="
281 :     | /= => "/="
282 :     | %= => "%="
283 :     | <<= => "<<="
284 :     | >>= => ">>="
285 :     | &= => "&="
286 :     | ^= => "^="
287 :     | |= => "|="
288 :     (* end case *))
289 : jhr 1115
290 :     fun binopToString rator = (case rator
291 : jhr 1368 of #|| => "||"
292 :     | #&& => "&&"
293 :     | #== => "=="
294 : jhr 1444 | #| => "|"
295 :     | #^ => "^"
296 :     | #& => "&"
297 : jhr 1368 | #!= => "!="
298 :     | #< => "<"
299 :     | #<= => "<="
300 :     | #>= => ">="
301 :     | #> => ">"
302 :     | #<< => "<<"
303 :     | #>> => ">>"
304 :     | #+ => "+"
305 :     | #- => "-"
306 :     | #* => "*"
307 :     | #/ => "/"
308 :     | #% => "%"
309 :     (* end case *))
310 : jhr 1115
311 :     fun unopToString rator = (case rator
312 : jhr 1368 of %- => "-"
313 :     | %! => "!"
314 :     | %& => "&"
315 :     | %* => "*"
316 :     | %~ => "~"
317 :     | %++ => "++"
318 :     | %-- => "--"
319 :     (* end case *))
320 : jhr 1115
321 :     fun postopToString rator = (case rator
322 : jhr 1368 of ^++ => "++"
323 :     | ^-- => "--"
324 :     (* end case *))
325 : jhr 1115
326 : jhr 1640 (* generate verbatim text from a template string by substituting for placeholders
327 :     * Placeholders have the syntax @<id>@ and are replaced with the string associated
328 :     * with <id> in the list of substitutions. If <id> is empty, then no substitution
329 :     * is applied, instead the "@@" is replaced by "@".
330 :     *)
331 :     local
332 :     structure SS = Substring
333 : jhr 2116 fun verbatim sl subs = let
334 :     fun scan (start, ss, n, frags) = (case SS.getc ss
335 :     of SOME(#"@", rest) => let
336 :     val frags = SS.slice(start, 0, SOME n) :: frags
337 :     val (expansion, rest) = scanPlaceholder rest
338 :     in
339 :     scan (rest, rest, 0, expansion::frags)
340 :     end
341 :     | SOME(_, rest) => scan (start, rest, n+1, frags)
342 :     | NONE => SS.concat(List.rev(start::frags))
343 :     (* end case *))
344 :     and scanPlaceholder start = let
345 :     fun scan (ss, n) = (case SS.getc ss
346 :     of NONE => raise Fail "incomplete placeholder"
347 :     | SOME(#"@", rest) => (SS.string(SS.slice(start, 0, SOME n)), rest)
348 :     | SOME(_, rest) => scan (rest, n+1)
349 :     (* end case *))
350 :     val (placeholder, rest) = scan (start, 0)
351 :     in
352 :     if (placeholder = "")
353 :     then (SS.full "@", rest)
354 :     else (case List.find (fn (s, _) => (s = placeholder)) subs
355 :     of SOME(_, expansion) => (SS.full expansion, rest)
356 :     | NONE => raise Fail(concat["unknown placeholder @", placeholder, "@"])
357 :     (* end case *))
358 :     end
359 :     fun expand s = let
360 :     val ss = SS.full s
361 :     in
362 :     scan (ss, ss, 0, [])
363 :     end
364 :     in
365 :     List.map expand sl
366 :     end
367 : jhr 1640 in
368 : jhr 2116 fun verbatimDcl sl subs = D_Verbatim(verbatim sl subs)
369 :     fun verbatimStm sl subs = S_Verbatim(verbatim sl subs)
370 : jhr 1640 end (* local *)
371 :    
372 : jhr 1301 (* for debugging (not syntactically correct!) *)
373 : jhr 1115 fun expToString e = let
374 : jhr 1368 fun e2s (e, l) = (case e
375 :     of E_Grp e => "(" :: e2s(e, ")"::l)
376 :     | E_AssignOp(e1, rator, e2) => e2s(e1, assignopToString rator :: e2s(e2, l))
377 : jhr 2116 | E_Cond(e1, e2, e3) => "(" :: e2s(e1, "?" :: e2s(e2, ":" :: e2s (e3, ")" :: l)))
378 : jhr 1368 | E_BinOp(e1, rator, e2) => e2s(e1, binopToString rator :: e2s(e2, l))
379 :     | E_UnOp(rator, e) => unopToString rator :: e2s(e, l)
380 :     | E_PostOp(e, rator) => e2s(e, postopToString rator :: l)
381 : jhr 2708 | E_Apply(e, es) => let
382 : jhr 1368 fun args2s ([], l) = l
383 :     | args2s ([e], l) = e2s(e, l)
384 :     | args2s (e::es, l) = e2s(e, ","::args2s(es, l))
385 :     in
386 : jhr 2708 e2s(e, "(" :: args2s(es, ")"::l))
387 : jhr 1368 end
388 :     | E_Subscript(e1, e2) => e2s(e1, "[" :: e2s(e2, "]"::l))
389 :     | E_Select(e, f) => e2s(e, "." :: f :: l)
390 :     | E_Indirect(e, f) => e2s(e, "->" :: f :: l)
391 : jhr 1850 | E_Cast(ty, e) => "(ty)" :: e2s(e, l) (* FIXME: need tyToString *)
392 : jhr 1368 | E_Var x => x::l
393 :     | E_Int(n, _) => IntegerLit.toString n :: l
394 :     | E_Flt(f, _) => FloatLit.toString f :: l
395 :     | E_Bool b => Bool.toString b :: l
396 : jhr 2708 | E_Str s => "\"" :: String.toCString s :: "\"" :: l
397 :     | E_Char c => "'" :: Char.toCString c :: "'" :: l
398 : jhr 1368 | E_Sizeof ty => "sizeof(ty)" :: l
399 :     (* end case *))
400 :     in
401 :     String.concat(e2s(e, []))
402 :     end
403 : jhr 1115
404 :     end

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