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/src/compiler/FLINT/opt/loopify.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/FLINT/opt/loopify.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 191 - (view) (download)

1 : monnier 191 (* copyright 1998 YALE FLINT PROJECT *)
2 :     (* monnier@cs.yale.edu *)
3 :    
4 :     signature LOOPIFY =
5 :     sig
6 :     val loopify : FLINT.prog -> FLINT.prog
7 :     end
8 :    
9 :    
10 :     structure Loopify =
11 :     struct
12 :     local
13 :     structure F = FLINT
14 :     structure C = Collect
15 :     structure O = Option
16 :     structure M = IntmapF
17 :     structure LK = LtyKernel
18 :     in
19 :    
20 :     fun bug msg = ErrorMsg.impossible ("Loopify: "^msg)
21 :     val cplv = LambdaVar.dupLvar
22 :    
23 :     fun loopify (prog as (progkind,progname,progargs,progbody)) = let
24 :    
25 :     (* m: int intmap renaming for function calls
26 :     * tf:(int,int) option the current function (if any) and its tail version
27 :     * le: you get the idea *)
28 :     fun lexp m tf le = let
29 :     val loop = lexp m tf
30 :     in case le
31 :     of F.RET _ => le
32 :     | F.LET(lvs,body,le) => F.LET(lvs, lexp m NONE body, loop le)
33 :     | F.FIX(fdecs,le) =>
34 :     let fun cfun (fk:F.fkind as {isrec=SOME(ltys,F.LK_UNKNOWN),cconv,...},
35 :     f,args,body) =
36 :     let val fi = C.get f
37 :     val icallnb = C.icallnb fi
38 :     (* cpsopt uses the following condition:
39 :     * escape = 0 andalso !unroll_call > 0
40 :     * andalso (!call - !unroll_call > 1
41 :     * orelse List.exists (fn t=>t) inv)
42 :     * `escape = 0': I don't quite see the need for it, though it
43 :     * probably won't change much since etasplit should have
44 :     * made "everything" known already.
45 :     * `!call - !unroll_call > 1 orelse List.exists (fn t=>t) inv)':
46 :     * loopification is only useful if there is more than one
47 :     * external call or if there are loop invariants.
48 :     * Note that we deal with invariants elsewhere, so it's
49 :     * not a good reason to loopify here. *)
50 :     (*** rationale behind the restrictions: ***
51 :     * `icallnb = 0': loopification is pointless and will be
52 :     * undone by fcontract.
53 :     * `C.callnb fi <= icallnb + 1': if there's only one external
54 :     * call, loopification will probably (?) not be of much use
55 :     * and the same benefit would be had by just moving f *)
56 :     in if icallnb = 0 (* orelse (C.callnb fi <= icallnb + 1) *)
57 :     (* not a good loop candidate *)
58 :     then (fk, f, args, loop body)
59 :     else
60 :     let val fl = cplv f
61 :     val ft = cplv f
62 :     val largs = map (fn(v,t) => (cplv v, t)) args
63 :     val args' = map (fn(v,t) => (cplv v, t)) args
64 :     val cconv' =
65 :     case cconv
66 :     of (F.CC_FCT | F.CC_FUN(LK.FF_FIXED)) => cconv
67 :     | F.CC_FUN(LK.FF_VAR(f1,f2)) =>
68 :     F.CC_FUN(LK.FF_VAR(true,f2))
69 :     val nm = M.add(m, f, fl)
70 :     val tailloop =
71 :     F.FIX([({isrec=SOME(ltys, F.LK_WHILE),
72 :     known=true, inline=F.IH_SAFE,
73 :     cconv=cconv'}, ft, args,
74 :     lexp nm (SOME(f,ft)) body)],
75 :     F.APP(F.VAR ft, map (F.VAR o #1) largs))
76 :     in (fk, f, args',
77 :     F.FIX([({isrec=SOME(ltys, F.LK_LOOP),
78 :     known=true, inline=F.IH_SAFE,
79 :     cconv=cconv'}, fl, largs,
80 :     tailloop)],
81 :     F.APP(F.VAR fl, map (F.VAR o #1) args')))
82 :     end
83 :     end
84 :     | cfun (fk,f,args,body) = (fk, f, args, lexp m NONE body)
85 :     in F.FIX(map cfun fdecs, loop le)
86 :     end
87 :     | F.APP(F.VAR f,vs) =>
88 :     (let val fl = M.lookup m f
89 :     in case tf
90 :     of SOME(f',ft) => if f' = f then F.APP(F.VAR ft, vs)
91 :     else F.APP(F.VAR fl, vs)
92 :     | NONE => F.APP(F.VAR fl, vs)
93 :     end handle M.IntmapF => le)
94 :     | F.TFN((f,args,body),le) => F.TFN((f, args, loop body), loop le)
95 :     | F.TAPP(f,tycs) => le
96 :     | F.SWITCH(v,ac,arms,def) =>
97 :     let fun carm (con,le) = (con, loop le)
98 :     in F.SWITCH(v, ac, map carm arms, O.map loop def)
99 :     end
100 :     | F.CON(dc,tycs,v,lv,le) => F.CON(dc, tycs, v, lv, loop le)
101 :     | F.RECORD(rk,vs,lv,le) => F.RECORD(rk, vs, lv, loop le)
102 :     | F.SELECT(v,i,lv,le) => F.SELECT(v, i, lv, loop le)
103 :     | F.RAISE(v,ltys) => le
104 :     | F.HANDLE(le,v) => F.HANDLE(loop le, v)
105 :     | F.BRANCH(po,vs,le1,le2) => F.BRANCH(po, vs, loop le1, loop le2)
106 :     | F.PRIMOP(po,vs,lv,le) => F.PRIMOP(po, vs, lv, loop le)
107 :    
108 :     | F.APP _ => bug "unexpected APP"
109 :     end
110 :    
111 :     in
112 :     C.collect prog; (* Collect is way overkill here *)
113 :     (progkind, progname, progargs, lexp M.empty NONE progbody)
114 :     end
115 :    
116 :     end
117 :     end
118 :    

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