Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/ckit/src/ast-utils/simplifier/simplify-ast.sml
ViewVC logotype

Annotation of /sml/trunk/ckit/src/ast-utils/simplifier/simplify-ast.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 597 - (view) (download)

1 : dbm 597 (* Copyright (c) 1998 by Lucent Technologies *)
2 :    
3 :     (* The simplify transformation normalizes the C code by:
4 :     * o getting rid of pre and post-increments
5 :     * o getting rid of op='s
6 :     * o getting rid of nested assignments w/in expressions
7 :     * o getting rid of comma expressions
8 :     * o getting rid of questioncolon expressions
9 :     * o getting rid of arrows
10 :     * o translating all breaks and continues into jumps
11 :     * o translating all do, whiles, and fors into conditional jumps
12 :     * o translating all Label (id,stmt) into sequences Label (id,emptyStmt); stmt
13 :     * which allows for a more unified expression of control flow.
14 :     * o translating all global/static variables without (or with only partial)
15 :     * initializations into into explicit initializations to 0.
16 :     * o translating all local variable initializations into explicit assignments.
17 :     *
18 :     * The transformation introduces new identifiers, expressions, and statements.
19 :     * The pidtab and the aidtab are kept consistent but the opaidtab is not since it
20 :     * shouldn't be needed after this transformation. The tidtab is not affected by
21 :     * the transformation.
22 :     *
23 :     * The main transformation in the system is the simplicication of expressions into
24 :     * non-sideffecting forms. All side effects (op==,pre/pos-increment,assignment)
25 :     * expressions are lifted to statements. The grammar of expressions after this
26 :     * transformation is:
27 :     *
28 :     * exp ::= id
29 :     * | constant
30 :     * | primapp exp* - where the primapp does not have a side-effect
31 :     * | exp.exp
32 :     * | exp->exp
33 :     * | exp[exp]
34 :     * | *exp
35 :     * | &exp
36 :     * | sizeof exp - sizeof should have already been eliminated
37 :     * | {exp*}
38 :     *
39 :     * within the context of statements, where assignments and function calls must
40 :     * occur, top level expression have the following syntax:
41 :     *
42 :     * topExp ::= exp - ie the new, restricted form of expressions
43 :     * | exp (exp* ) - function calls
44 :     * | exp := exp - simple assignments
45 :     * | exp := exp (exp* ) - assignments of function call values
46 :     *
47 :     *
48 :     * Issues:
49 :     * Consider the following code:
50 :     *
51 :     * x->y->m += 12;
52 :     *
53 :     * This gets translated into:
54 :     *
55 :     * x->y->m = x->y->m + 12;
56 :     *
57 :     * by copying the arbitraily complex expression (x->y->m).
58 :     * The alternative is to introduce a temporary variable:
59 :     *
60 :     * temp = x->y
61 :     * temp->m = temp->m + 12;
62 :     *
63 :     * but this transformation is subtle as you can't write:
64 :     *
65 :     * temp = x->y->m
66 :     * temp = temp + 12;
67 :     *
68 :     *)
69 :    
70 :     structure SimplifyAst : SIMPLIFYAST =
71 :     struct
72 :    
73 :     structure Ast = Ast
74 :     structure Copy = CopyAst
75 :     open Ast
76 :    
77 :     exception simplifyExn
78 :    
79 :     fun warn msg = print msg
80 :    
81 :     fun fail msg = (print msg; raise simplifyExn)
82 :    
83 :     val strictlyPrintable = ref true (* try to make it acceptable C code: see handling of casts *)
84 :    
85 :     val sizeOf = Sizeof.byteSizeOf {warn=warn,err=fail, bug=fail}
86 :    
87 :     fun lookup looker id =
88 :     case looker id
89 :     of NONE => fail "trying to lookup id"
90 :     | SOME v => v
91 :    
92 :     fun simplifyAst (edecls,tidtab,aidtab,opaidtab) =
93 :     let
94 :     val esctab = Pidtab.uidtab () : unit Pidtab.uidtab
95 :     val getTid = lookup (fn tid => Tidtab.find (tidtab,tid))
96 :     val getOpAid = lookup (fn aid => Aidtab.find (opaidtab,aid))
97 :    
98 :     fun copyExp exp = Copy.copyExpr aidtab exp
99 :    
100 :     fun newLabel name =
101 :     { name=Symbol.label name
102 :     , uid = Pid.new ()
103 :     , location=SourceMap.UNKNOWN
104 :     }
105 :    
106 :     fun newId name ctype =
107 :     { name=Symbol.object name
108 :     , uid=Pid.new()
109 :     , location=SourceMap.UNKNOWN
110 :     , ctype=ctype
111 :     , stClass=Ast.DEFAULT,
112 :     global=false,
113 :     status=DECLARED
114 :     , kind= if TypeUtil.isFunction tidtab ctype then Ast.FUNCTION{hasFunctionDef=false}
115 :     else Ast.NONFUN
116 :     }
117 :    
118 :     fun addEscape pid =
119 :     Pidtab.insert(esctab,pid,())
120 :    
121 :     (* fix: this code is incomplete ... *)
122 :     (* lval ::= id | id.field | expr[expr'] | expr->field | *expr *)
123 :     fun escapes (EXPR (Id {uid=pid,...},_,_)) = addEscape pid
124 :     | escapes (EXPR (Member (expr, _))) = escapes expr
125 :     | escapes _ = ()
126 :    
127 :     (* Generate a new aid, bind it to ty in aidtab, and return it *)
128 :     fun bindAid ctype =
129 :     let val aid = Aid.new ()
130 :     in Aidtab.insert(aidtab,aid,ctype);
131 :     aid
132 :     end
133 :    
134 :     fun id2ctype (id: Ast.id) = #ctype id
135 :    
136 :     fun isStaticOrGlobal ({stClass=Ast.STATIC,...}: Ast.id) = true
137 :     | isStaticOrGlobal {global=true,...} = true
138 :     | isStaticOrGlobal _ = false
139 :    
140 :     fun aid2ctype aid =
141 :     case Aidtab.find (aidtab,aid)
142 :     of NONE => ( print "unknown type for aid "
143 :     ; print (Aid.toString aid)
144 :     ; print ",assuming its void\n"
145 :     ; Ast.Void
146 :     )
147 :     | SOME ctype => ctype
148 :    
149 :     fun exp2ctype (EXPR (_,aid,_)) = aid2ctype aid
150 :    
151 :     fun coreExp2exp ctype coreExp = EXPR (coreExp,bindAid ctype,SourceMap.UNKNOWN)
152 :    
153 :     fun coreStmt2stmt coreStmt = STMT (coreStmt,Aid.new (),SourceMap.UNKNOWN)
154 :    
155 :     fun exp2stmt exp = coreStmt2stmt (Expr (SOME exp))
156 :    
157 :     fun coreExp2stmt ctype coreExp = exp2stmt (coreExp2exp ctype coreExp)
158 :    
159 :     fun mkId id =
160 :     coreExp2exp (id2ctype id) (Id id)
161 :    
162 :     fun label id =
163 :     coreStmt2stmt (Labeled (id,coreStmt2stmt (Expr NONE)))
164 :    
165 :     fun assign id exp =
166 :     let val ctype = id2ctype id
167 :     in coreExp2stmt ctype (Assign (mkId id,exp)) end
168 :    
169 :     (* dpo: eqCtype this is potentially expensive, should we do this? *)
170 :     fun cast ctype exp =
171 :     if CTypeEq.eqCType(ctype, (exp2ctype exp)) then exp
172 :     else coreExp2exp ctype (Cast (ctype,exp))
173 :    
174 :     fun decl id =
175 :     let val ctype = id2ctype id
176 :     in VarDecl (id,NONE) end
177 :    
178 :     fun compound decls stmts =
179 :     let fun filter [] = ([],[])
180 :     | filter (stmt::stmts) =
181 :     let val (decls,stmts) = filter stmts
182 :     in case stmt
183 :     of STMT (Compound (cmpDecls,cmpStmts),_,_) => (cmpDecls@decls,cmpStmts@stmts)
184 :     | STMT (Expr NONE,_,_) => (decls,stmts)
185 :     | _ => (decls,stmt::stmts)
186 :     end
187 :     val (decls',stmts') = filter stmts
188 :     in Compound (decls@decls',stmts') end
189 :    
190 :     fun noEffect (EXPR (coreExpr,_,_)) =
191 :     case coreExpr
192 :     of IntConst _ => true
193 :     | RealConst _ => true
194 :     | StringConst _ => true
195 :     | Id _ => true
196 :     | _ => false
197 :    
198 :     fun stmts2stmt [] [stmt] = stmt
199 :     | stmts2stmt decls stmts = STMT (compound decls stmts,Aid.new (),
200 :     SourceMap.UNKNOWN)
201 :    
202 :     val intCt = Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.SIGNED,Ast.INT, Ast.SIGNASSUMED)
203 :    
204 :     val charCt = Ast.Numeric (Ast.NONSATURATE,Ast.WHOLENUM,Ast.UNSIGNED,Ast.CHAR, Ast.SIGNASSUMED)
205 :    
206 :     fun mkInt i = coreExp2exp intCt (IntConst (i:LargeInt.int))
207 :    
208 :     fun mkChr c = coreExp2exp charCt (IntConst (Int32.fromInt (ord c)))
209 :    
210 :     fun simplifyExtDecls edecls =
211 :     map simplifyExtDecl edecls
212 :    
213 :     and simplifyExtDecl (DECL (coreExtDecl,aid,loc)) =
214 :     DECL (simplifyCoreExtDecl coreExtDecl,aid,loc)
215 :    
216 :     and simplifyCoreExtDecl coreExtDecl =
217 :     case coreExtDecl
218 :     of ExternalDecl decl => ExternalDecl decl
219 :     | FunctionDef (id,ids,stmt) =>
220 :     (case simplifyStmt (NONE,NONE) stmt
221 :     of {decs=[],stmts=[stmt]} => FunctionDef (id,ids,stmt)
222 :     | {decs,stmts} =>
223 :     FunctionDef (id,ids,coreStmt2stmt (compound decs stmts)))
224 :     | ExternalDeclExt ext =>
225 :     SimplifyAstExt.simplifyExtDeclExt
226 :     (tidtab,aidtab,opaidtab)
227 :     (simplifyNestedExp, simplifyStmt (NONE,NONE))
228 :     ext
229 :    
230 :     and simplifyDecls [] = {decs=[],stmts=[]}
231 :     | simplifyDecls (decl::decls) =
232 :     let val {decs=decs0,stmts=stmts0} = simplifyDecl decl
233 :     val {decs=decs1,stmts=stmts1} = simplifyDecls decls
234 :     in {decs=decs0@decs1,stmts=stmts0@stmts1} end
235 :    
236 :     and simplifyDecl decl =
237 :     case decl
238 :     of TypeDecl tid => {decs=[decl],stmts=[]}
239 :     | VarDecl (id,NONE) => {decs=[decl],stmts=[]}
240 :     | VarDecl (id,SOME initExpr) =>
241 :     if isStaticOrGlobal id
242 :     then {decs=[VarDecl (id,SOME initExpr)],stmts=[]}
243 :     else let val ctype = id2ctype id
244 :     val dec = VarDecl (id, NONE)
245 :     val {decs,stmts} = simplifyAutoInit (mkId id) ctype initExpr
246 :     in {decs=decs@[dec],stmts=stmts} end
247 :    
248 :     and simplifyStmts pair [] = {decs=[],stmts=[]}
249 :     | simplifyStmts pair (stmt::stmts) =
250 :     let val {decs=decs0,stmts=stmts0} = simplifyStmt pair stmt
251 :     val {decs=decs1,stmts=stmts1} = simplifyStmts pair stmts
252 :     in {decs=decs0@decs1,stmts=stmts0@stmts1} end
253 :    
254 :    
255 :     and simplifyStmt (pair as (contOpt,brkOpt))
256 :     (stmt as STMT (coreStmt,aid,loc)) =
257 :     let fun mkStmt coreStmt = STMT (coreStmt,aid,loc)
258 :     fun cs2stmt coreStmt = STMT (coreStmt,Aid.new (),loc)
259 :     in case coreStmt
260 :     of Expr expOpt =>
261 :     let val {decs,pre,expOpt} = simplifyTopExpOpt expOpt
262 :     val stmt = mkStmt (Expr expOpt)
263 :     in {decs=decs,stmts=pre@[stmt]} end
264 :     | Compound (decls,stmts) =>
265 :     let val {decs=decs0,stmts=stmts0}= simplifyDecls decls
266 :     val {decs=decs1,stmts=stmts1} = simplifyStmts pair stmts
267 :     in {decs=decs0@decs1,stmts=[mkStmt (compound [] (stmts0@stmts1))]} end
268 :     (* The translation of while minimizes the number of jumps
269 :     * in the body of the loop.
270 :     *
271 :     * while (exp,stmt) =>
272 :     * goto startLabel
273 :     * topLabel: stmt
274 :     * start&contLabel: preExp
275 :     * if exp then goto topLabel
276 :     * brkLabel:
277 :     *
278 :     * NOTE: the brk label is added only if is used.
279 :     *)
280 :     | While (exp,stmt) =>
281 :     let val topLab = newLabel "whileTop"
282 :     val contLab = newLabel "whileCont"
283 :     val brkLab = newLabel "whileBrk"
284 :     val contUsed = ref true
285 :     val brkUsed = ref false
286 :     val pair = (SOME (contUsed,contLab),SOME (brkUsed,brkLab))
287 :     val {decs=expDecs,pre=preExp,exp=exp} = simplifyTopExp exp
288 :     val {decs=bodyDecs,stmts} = simplifyStmt pair stmt
289 :     val stmts = [cs2stmt (Goto contLab),
290 :     label topLab
291 :     ]
292 :     @ stmts
293 :     @ [label contLab]
294 :     @ preExp
295 :     @ [mkStmt (IfThen (exp,cs2stmt (Goto topLab)))]
296 :     @ (if !brkUsed then [label brkLab] else [])
297 :     in {decs=expDecs@bodyDecs,stmts=stmts} end
298 :     (* The translation of do minimizes the number of jumps
299 :     * in the body of the loop.
300 :     *
301 :     * do (exp,stmt) =>
302 :     * topLabel: stmt
303 :     * contLabel: preExp
304 :     * if exp then goto topLabel
305 :     * brkLabel:
306 :     *
307 :     * NOTE: cont and brk labels are added only if they are used.
308 :     *)
309 :     | Do (exp,stmt) =>
310 :     let val topLab = newLabel "doTop"
311 :     val contLab = newLabel "doCont"
312 :     val brkLab = newLabel "doBrk"
313 :     val contUsed = ref false
314 :     val brkUsed = ref false
315 :     val pair = (SOME (contUsed,contLab),SOME (brkUsed,brkLab))
316 :     val {decs=expDecs,pre=preExp,exp} = simplifyTopExp exp
317 :     val {decs=bodyDecs,stmts} = simplifyStmt pair stmt
318 :     val stmts = [label topLab]
319 :     @ stmts
320 :     @ (if !contUsed then [label contLab] else [])
321 :     @ preExp
322 :     @ [mkStmt (IfThen (exp,mkStmt (Goto topLab)))]
323 :     @ (if !brkUsed then [label brkLab] else [])
324 :     in {decs=expDecs@bodyDecs,stmts=stmts} end
325 :     (* The translation of for minimizes the number of jumps
326 :     * in the body of the loop.
327 :     *
328 :     * for (e0,e1,e2,stmt) =>
329 :     * preE0
330 :     * e0
331 :     * goto startLabel
332 :     * topLabel: stmt
333 :     * contLabel: preE2
334 :     * e2
335 :     * startLabel: preE1
336 :     * if e1 then goto topLabel
337 :     * brkLabel:
338 :     *
339 :     * NOTE: cont and brk labels are added only if they are used.
340 :     *)
341 :     | For (eOpt0,eOpt1,eOpt2,stmt) =>
342 :     let val topLab = newLabel "forTop"
343 :     val startLab = newLabel "forStart"
344 :     val contLab = newLabel "forCont"
345 :     val brkLab = newLabel "forBrk"
346 :     val contUsed = ref false
347 :     val brkUsed = ref false
348 :     val pair = (SOME (contUsed,contLab),SOME (brkUsed,brkLab))
349 :     val {decs=e0Decs,pre=preE0,expOpt=eOpt0} = simplifyTopExpOpt eOpt0
350 :     val {decs=e1Decs,pre=preE1,expOpt=eOpt1} = simplifyTopExpOpt eOpt1
351 :     val {decs=e2Decs,pre=preE2,expOpt=eOpt2} = simplifyTopExpOpt eOpt2
352 :     val {decs=bodyDecs,stmts} = simplifyStmt pair stmt
353 :     fun expOpt2stmt NONE = []
354 :     | expOpt2stmt (SOME exp) =
355 :     if noEffect exp then [] else [exp2stmt exp]
356 :    
357 :     val stmts = preE0
358 :     @ expOpt2stmt eOpt0
359 :     @ [cs2stmt (Goto startLab)
360 :     ,label topLab
361 :     ]
362 :     @ stmts
363 :     @ (if !contUsed then [label contLab] else [])
364 :     @ preE2
365 :     @ expOpt2stmt eOpt2
366 :     @ [label startLab]
367 :     @ preE1
368 :     @ (case eOpt1
369 :     of SOME e1 => [mkStmt (IfThen (e1,cs2stmt (Goto topLab)))]
370 :     | NONE => [])
371 :     @ (if !brkUsed then [label brkLab] else [])
372 :     in {decs=e0Decs@e1Decs@e2Decs@bodyDecs,stmts=stmts} end
373 :     | Labeled (label,stmt) =>
374 :     let val {decs,stmts} = simplifyStmt pair stmt
375 :     val stmt = mkStmt (Labeled (label,cs2stmt (Expr NONE)))
376 :     in {decs=decs,stmts=stmt::stmts} end
377 :     | CaseLabel (li,stmt) =>
378 :     let val {decs,stmts} = simplifyStmt pair stmt
379 :     in {decs=decs,stmts=[mkStmt (CaseLabel (li,stmts2stmt [] stmts))]}
380 :     end
381 :     | DefaultLabel stmt =>
382 :     let val {decs,stmts} = simplifyStmt pair stmt
383 :     in {decs=decs,stmts=[mkStmt (DefaultLabel (stmts2stmt [] stmts))]}
384 :     end
385 :     | Goto label => {decs=[],stmts=[mkStmt (Goto label)]}
386 :     | Break =>
387 :     (case brkOpt
388 :     of NONE => fail "invalid context for break"
389 :     | SOME (brkUsed,label) =>
390 :     ( brkUsed := true
391 :     ; {decs=[],stmts=[mkStmt (Goto label)]}
392 :     ))
393 :     | Continue =>
394 :     (case contOpt
395 :     of NONE => fail "invalid context for continue"
396 :     | SOME (contUsed,label) =>
397 :     (contUsed := true;
398 :     {decs=[],stmts=[mkStmt (Goto label)]}))
399 :     | Return expOpt =>
400 :     let val {decs,pre,expOpt} = simplifyTopExpOpt expOpt
401 :     in {decs=decs,stmts=pre@[mkStmt (Return expOpt)]}
402 :     end
403 :     | IfThen (exp,stmt) =>
404 :     let val {decs=decs0,pre,exp} = simplifyTopExp exp
405 :     val {decs=decs1,stmts} = simplifyStmt pair stmt
406 :     val stmts = pre@[mkStmt (IfThen (exp,stmts2stmt [] stmts))]
407 :     in {decs=decs0@decs1,stmts=stmts}
408 :     end
409 :     | IfThenElse (exp,stmt0,stmt1) =>
410 :     let val {decs,pre,exp} = simplifyTopExp exp
411 :     val {decs=decs0,stmts=stmts0} = simplifyStmt pair stmt0
412 :     val {decs=decs1,stmts=stmts1} = simplifyStmt pair stmt1
413 :     val stmts =
414 :     pre@[mkStmt(IfThenElse(exp,stmts2stmt [] stmts0,
415 :     stmts2stmt [] stmts1))]
416 :     in {decs=decs@decs0@decs1,stmts=stmts} end
417 :     | Switch (exp,stmt) =>
418 :     let val {decs=decs0,pre,exp} = simplifyTopExp exp
419 :     val brkLab = newLabel "switchBrk"
420 :     val brkUsed = ref false
421 :     val {decs=decs1,stmts} =
422 :     simplifyStmt (contOpt,SOME (brkUsed,brkLab)) stmt
423 :     val stmts = pre
424 :     @ [mkStmt (Switch (exp,stmts2stmt [] stmts))]
425 :     @ (if !brkUsed then [label brkLab] else [])
426 :     in {decs=decs0@decs1,stmts=stmts}
427 :     end
428 :     | ErrorStmt => {decs=nil, stmts=[mkStmt ErrorStmt]}
429 :     | StatExt ext =>
430 :     let val {decs,coreStmt} =
431 :     SimplifyAstExt.simplifyStmtExt
432 :     (tidtab,aidtab,opaidtab)
433 :     (simplifyNestedExp,simplifyStmt (NONE,NONE))
434 :     ext
435 :     in {decs=decs,stmts=[mkStmt coreStmt]}
436 :     end
437 :     end
438 :    
439 :    
440 :     and simplifyAutoInit lhs ctype initExp =
441 :     case initExp
442 :     of (Aggregate initExps) =>
443 :     let val {stmts} = autoInit lhs ctype initExp
444 :     in {decs=[],stmts=stmts} end
445 :     | (Simple exp) =>
446 :     let val {decs,pre,exp} = simplifyTopExp exp
447 :     val stmt = coreExp2stmt ctype (Assign (lhs,exp))
448 :     in {decs=decs,stmts=pre@[stmt]} end
449 :    
450 :     and autoInit lhs ctype initExp =
451 :     let fun feed initer (Aggregate initExps) = initer initExps
452 :     | feed initer _ = fail "bad form for initializer"
453 :    
454 :     fun arrInit lhs ctype i [] = {stmts=[]}
455 :     | arrInit lhs ctype i (initExp::initExps) =
456 :     let val intConst = mkInt i
457 :     val arrLhs = coreExp2exp ctype (Sub (lhs,intConst))
458 :     val {stmts} = autoInit arrLhs ctype initExp
459 :     val {stmts=stmts'} = arrInit lhs ctype (i+1) initExps
460 :     in {stmts=stmts@stmts'} end
461 :    
462 :     fun structInit lhs [] [] = {stmts=[]}
463 :     | structInit lhs [] initExps = fail "initializer too big"
464 :     | structInit lhs fields [] = fail "initializer too small"
465 :     | structInit lhs ((ctype,NONE,liOpt)::fields) initExps =
466 :     (* according to the standard, unnamed fields don't
467 :     * get initialized.
468 :     *)
469 :     structInit lhs fields initExps
470 :     | structInit lhs ((ctype,SOME mem,liOpt)::fields) (initExp::initExps) =
471 :     let val memLhs = coreExp2exp ctype (Member (lhs,mem))
472 :     val {stmts} = autoInit memLhs ctype initExp
473 :     val {stmts=stmts'} = structInit lhs fields initExps
474 :     in {stmts=stmts@stmts'} end
475 :    
476 :     fun unionInit lhs [] initExps = {stmts=[]}
477 :     | unionInit lhs ((ctype,mem)::_) ([initExp]) =
478 :     let val lhs = coreExp2exp ctype (Member (lhs,mem))
479 :     in autoInit lhs ctype initExp end
480 :     | unionInit lhs fields exp = fail "bad form for union"
481 :    
482 :     fun scalarInit lhs ctype (Simple exp) =
483 :     {stmts=[coreExp2stmt ctype (Assign (lhs,exp))]}
484 :     | scalarInit lhs ctype _ =
485 :     fail "bad form for initializer"
486 :    
487 :     in case ctype
488 :     of Ast.Qual (_,ctype) => autoInit lhs ctype initExp
489 :     | Ast.TypeRef tid =>
490 :     (case getTid tid
491 :     of {ntype=SOME (Bindings.Typedef (tid,ctype)),...} =>
492 :     autoInit lhs ctype initExp
493 :     | _ => fail "bad type for initializer")
494 :     | Ast.Array (_,ctype) => feed (arrInit lhs ctype 0) initExp
495 :     | Ast.StructRef tid =>
496 :     (case getTid tid
497 :     of {ntype=SOME (Bindings.Struct (tid,fields)),...} =>
498 :     feed (structInit lhs fields) initExp
499 :     | _ => fail "bad type for initializer")
500 :     | Ast.UnionRef tid =>
501 :     (case getTid tid
502 :     of {ntype=SOME (Bindings.Union (tid,fields)),...} =>
503 :     feed (unionInit lhs fields) initExp
504 :     | _ => fail "bad type for initializer")
505 :     | Ast.Numeric _ => scalarInit lhs ctype initExp
506 :     | Ast.Pointer _ => scalarInit lhs ctype initExp
507 :     | Ast.Function _ => scalarInit lhs ctype initExp
508 :     | Ast.EnumRef _ => scalarInit lhs ctype initExp
509 :     | _ => fail "bad type for initializer"
510 :     end
511 :    
512 :     and simplifyExps [] = {decs=[],pre=[],exps=[]}
513 :     | simplifyExps (exp::exps) =
514 :     let val {decs,pre,exp} = simplifyExp {nested=true} exp
515 :     val {decs=decs',pre=pre',exps} = simplifyExps exps
516 :     in {decs=decs@decs',pre=pre@pre',exps=exp::exps} end
517 :    
518 :     and simplifyNestedExp exp = simplifyExp {nested=true} exp
519 :    
520 :     and simplifyTopExp exp = simplifyExp {nested=false} exp
521 :    
522 :     and simplifyTopExpOpt NONE = {decs=[],pre=[],expOpt=NONE}
523 :     | simplifyTopExpOpt (SOME exp) =
524 :     let val {decs,pre,exp} = simplifyTopExp exp
525 :     in {decs=decs,pre=pre,expOpt=SOME exp} end
526 :    
527 :    
528 :     and simplifyExp {nested} (exp as EXPR (coreExp,aid,loc)) =
529 :     let fun mkExp coreExp = EXPR (coreExp,aid,loc)
530 :     val ctype = aid2ctype aid
531 :     in case coreExp
532 :     of IntConst _ => {decs=[],pre=[],exp=exp}
533 :     | RealConst _ => {decs=[],pre=[],exp=exp}
534 :     | StringConst _ => {decs=[],pre=[],exp=exp}
535 :     | Call (exp,exps) =>
536 :     let val {decs=decs0,pre=pre0,exp} = simplifyNestedExp exp
537 :     val {decs=decs1,pre=pre1,exps} = simplifyExps exps
538 :     val callExp = mkExp (Call (exp,exps))
539 :     in if nested
540 :     then let val id = newId "call" ctype
541 :     val dec = decl id
542 :     val stmt = assign id callExp
543 :     val exp = mkId id
544 :     in {decs=dec::decs0@decs1,pre=pre0@pre1@[stmt],exp=exp} end
545 :     else {decs=decs0@decs1,pre=pre0@pre1,exp=callExp}
546 :     end
547 :     | QuestionColon (exp0,exp1,exp2) =>
548 :     let val id = newId "quesCol" ctype
549 :     val dec = decl id
550 :     val {decs=decs0,pre=pre0,exp=exp0} = simplifyNestedExp exp0
551 :     val {decs=decs1,pre=pre1,exp=exp1} = simplifyTopExp exp1
552 :     val {decs=decs2,pre=pre2,exp=exp2} = simplifyTopExp exp2
553 :     val stmt = coreStmt2stmt
554 :     (IfThenElse
555 :     ( exp0
556 :     , stmts2stmt decs1 (pre1@[assign id exp1])
557 :     , stmts2stmt decs2 (pre2@[assign id exp2])
558 :     )
559 :     )
560 :     val exp = mkId id
561 :     in {decs=dec::decs0,pre=pre0@[stmt],exp=exp} end
562 :     | Assign (exp0,exp1) =>
563 :     let val {decs=decs0,pre=pre0,exp=exp0} = simplifyNestedExp exp0
564 :     val {decs=decs1,pre=pre1,exp=exp1} = simplifyNestedExp exp1
565 :     val exp = mkExp (Assign (exp0,exp1))
566 :     in if nested
567 :     then {decs=decs0@decs1,pre=pre0@pre1@[exp2stmt exp],exp=exp0}
568 :     else{decs=decs0@decs1,pre=pre0@pre1,exp=exp}
569 :     end
570 :     | Comma (exp0,exp1) =>
571 :     let val {decs=decs0,pre=pre0,exp=exp0} = simplifyNestedExp exp0
572 :     val {decs=decs1,pre=pre1,exp=exp1} = simplifyNestedExp exp1
573 :     val pre = if noEffect exp0 then pre0@pre1 else pre0@[exp2stmt exp0]@pre1
574 :     in {decs=decs0@decs1,pre=pre,exp=exp1} end
575 :     | Sub (exp0,exp1) =>
576 :     let val {decs=decs0,pre=pre0,exp=exp0} = simplifyNestedExp exp0
577 :     val {decs=decs1,pre=pre1,exp=exp1} = simplifyNestedExp exp1
578 :     val exp = mkExp (Sub (exp0,exp1))
579 :     in {decs=decs0@decs1,pre=pre0@pre1,exp=exp} end
580 :     | Member (exp,mem) =>
581 :     let val {decs,pre,exp} = simplifyNestedExp exp
582 :     val exp = mkExp (Member (exp,mem))
583 :     in {decs=decs,pre=pre,exp=exp} end
584 :     | Arrow (exp,mem) =>
585 :     (case exp2ctype exp
586 :     of Ast.Pointer ctype =>
587 :     let val {decs,pre,exp} = simplifyNestedExp exp
588 :     val exp = coreExp2exp ctype (Deref exp)
589 :     val exp = mkExp (Member (exp,mem))
590 :     in {decs=decs,pre=pre,exp=exp} end
591 :     | _ => fail "Arrow: type error")
592 :     | Deref exp =>
593 :     let val {decs,pre,exp} = simplifyNestedExp exp
594 :     val exp = mkExp (Deref exp)
595 :     in {decs=decs,pre=pre,exp=exp} end
596 :     (***
597 :     | AddrOf exp =>
598 :     let val {decs,pre,exp} = simplifyNestedExp exp
599 :     val exp = mkExp (AddrOf exp)
600 :     in (escapes exp; {decs=decs,pre=pre,exp=exp}) end
601 :     ***)
602 :    
603 :     (* notes on addrOf:
604 :     s: effect of simplifyNestedExp
605 :     a: effect of adrf
606 :     1. x =s=> x =a=> &x
607 :     2. x->field =s=> *(x+k) =a=> x+k where k is offset of field
608 :     3. x.field =s=> *((&x)+k) =a=> &x+k where k is offset of field
609 :     4. e[i] =s=> *(e+i*k) =a=> e+i*k where k is scaling for ( *e)
610 :     5. x[i] =s=> *(&x+i*k)
611 :     **)
612 :     | AddrOf exp =>
613 :     let
614 :     val {decs, pre, exp} = simplifyNestedExp exp
615 :     fun adrf(expr as EXPR(coreExpr, aid, loc)) =
616 :     (case coreExpr of
617 :     Id{uid=pid, ...} =>
618 :     (addEscape pid;
619 :     exp=EXPR(AddrOf expr, aid, loc))
620 :     | Member(memExpr, field) =>
621 :     let val expr = adrf(memExpr)
622 :     val ctype = exp2ctype(memExpr)
623 :     fun nullErr _ = ()
624 :     val errs = {err=nullErr, warn=nullErr, bug=nullErr}
625 :     val fieldOffs = Sizeof.fieldOffsets errs tidtab ctype
626 :     val byteOffset = #bitOffset(Sizeof.getField errs (field, fieldOffs))
627 :     in
628 :     EXPR(Binop(Plus(exp, byteOffset)), aid, loc)
629 :     end
630 :     | Deref expr => expr
631 :     | (Sub _ | Arrow _) => fail "simplifyNestedExp returned Sub or Arrow")
632 :     (* x[4] -> *(x+16) -> x+16 *)
633 :     in
634 :     {decs=decs, pre=pre, exp=adrf exp}
635 :     end
636 :    
637 :     let val {decs,pre,exp} = simplifyNestedExp exp
638 :     val exp = mkExp (AddrOf exp)
639 :     in (escapes exp; {decs=decs,pre=pre,exp=exp}) end
640 :    
641 :     | Binop trip =>
642 :     simplifyBinop mkExp {nested=nested} ctype trip
643 :     | Unop pair =>
644 :     let val {decs,pre,coreExp} = simplifyUnop {nested=nested} ctype pair
645 :     in {decs=decs,pre=pre,exp=mkExp coreExp} end
646 :     | Cast (ctype,exp) =>
647 :     let val {decs,pre,exp} = simplifyNestedExp exp
648 :     in
649 :     {decs=decs, pre=pre, exp= mkExp(Cast(ctype, exp))}
650 :     end
651 :     | Id _ => {decs=[],pre=[],exp=exp}
652 :     | EnumId _ => {decs=[],pre=[],exp=exp}
653 :     | SizeOf _ => {decs=[],pre=[],exp=exp} (* should not appear in compiler mode *)
654 :     | ExprExt ext =>
655 :     let val {decs,pre,coreExp} =
656 :     SimplifyAstExt.simplifyExpExt
657 :     (tidtab,aidtab,opaidtab)
658 :     (simplifyNestedExp, simplifyStmt(NONE,NONE))
659 :     ext
660 :     in {decs=decs,pre=pre,exp=mkExp coreExp}
661 :     end
662 :     | ErrorExpr => {decs=[],pre=[],exp=exp}
663 :     end
664 :    
665 :     and scale ctype i =
666 :     case ctype
667 :     of Ast.Qual (_,ctype) => scale ctype i
668 :     | Ast.Pointer ctype => let val {bytes,...} = sizeOf tidtab ctype
669 :     in LargeInt.fromInt (bytes * i) end
670 :     | _ => LargeInt.fromInt i
671 :    
672 :     and simplifyUnop {nested} ctype (unop,exp as EXPR (_,aid,_)) =
673 :     let val {decs,pre,exp} = simplifyNestedExp exp
674 :     fun mkUnop unop = {decs=decs,pre=pre,coreExp=Unop (unop,exp)}
675 :     fun mkAssign {prefixOp} binop =
676 :     (* opArgTy is type to which arg is converted
677 :     e.g. e++ where e has type ctype and opArgTy newTy
678 :     becomes e = (ctype)( (newTy)e + (newTy)1 )
679 :     and if ctype is a pointer, then 1 gets scaled by sizeof( *ctype )
680 :     *)
681 :     let val id = newId (if prefixOp then "pref" else "post") ctype
682 :     val dec = decl id
683 :     val newTy = getOpAid aid
684 :     val argExp = cast newTy exp
685 :     val one = cast newTy
686 :     (coreExp2exp intCt (IntConst (scale ctype 1)))
687 :     val binExp = coreExp2exp newTy (Binop (binop,argExp,one))
688 :     val incrStmt = coreExp2stmt ctype
689 :     (Assign(copyExp exp, cast ctype binExp))
690 :     val assignStmt =
691 :     coreExp2stmt ctype (Assign (mkId id,copyExp exp))
692 :     val pre = if prefixOp then pre@[incrStmt,assignStmt]
693 :     else pre@[assignStmt,incrStmt]
694 :     in {decs=dec::decs, pre=pre, coreExp=Id id}
695 :     end
696 :     in case unop
697 :     (* the ++, --, cases are no longer dealt with in here;
698 :     there is now code in build-ast (which is
699 :     enabled when insert_explicit_coersions is set)
700 :     that simplifies ++ and -- *)
701 :     of PreInc => mkAssign {prefixOp=true} Plus
702 :     | PreDec => mkAssign {prefixOp=true} Minus
703 :     | PostInc => mkAssign {prefixOp=false} Plus
704 :     | PostDec => mkAssign {prefixOp=false} Minus
705 :     | _ => mkUnop unop
706 :     end
707 :    
708 :     and simplifyBinop mkExp {nested} ctype (binop,exp0 as EXPR (_,aid,_),exp1) =
709 :     let val {decs=decs0,pre=pre0,exp=exp0} = simplifyNestedExp exp0
710 :     val {decs=decs1,pre=pre1,exp=exp1} = simplifyNestedExp exp1
711 :     val decs = decs0@decs1
712 :     val pre = pre0@pre1
713 :     fun mkBinop binop =
714 :     {decs=decs,pre=pre,exp=mkExp (Binop (binop,exp0,exp1))}
715 :     fun mkAssign binop =
716 :     (* for e0 += e1, e0 -= e1 and their friends, opArgTy specifies
717 :     the type that e0 must be converted to
718 :     e.g. e0 += e1 becomes e0 = (ctype(e0)) ( (opArgTy e0) + e1 )
719 :     *)
720 :     let val opArgTy = getOpAid aid
721 :     val binExp = coreExp2exp opArgTy
722 :     (Binop (binop,cast opArgTy exp0,exp1))
723 :     val assign = mkExp (Assign (copyExp exp0,cast ctype binExp))
724 :     in if nested
725 :     then {decs=decs,pre=pre@[exp2stmt assign],exp=copyExp exp0}
726 :     else {decs=decs,pre=pre,exp=assign}
727 :     end
728 :     in case binop
729 :     (* the +=, -=, etc., cases are no longer dealt with in here;
730 :     there is now code in build-ast (which is
731 :     enabled when insert_explicit_coersions is set)
732 :     that simplifies +=, -=, ... *)
733 :     of PlusAssign => mkAssign Plus
734 :     | MinusAssign => mkAssign Minus
735 :     | TimesAssign => mkAssign Times
736 :     | DivAssign => mkAssign Divide
737 :     | ModAssign => mkAssign Mod
738 :     | XorAssign => mkAssign BitXor
739 :     | OrAssign => mkAssign Or
740 :     | AndAssign => mkAssign And
741 :     | LshiftAssign => mkAssign Lshift
742 :     | RshiftAssign => mkAssign Rshift
743 :     | _ => mkBinop binop
744 :     end
745 :     in {ast=simplifyExtDecls edecls, escapetab = esctab}
746 :     end
747 :     end

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