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

SCM Repository

[smlnj] Diff of /sml/trunk/src/compiler/FLINT/opt/loopify.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 198, Sun Nov 22 02:11:29 1998 UTC revision 199, Wed Nov 25 18:30:38 1998 UTC
# Line 7  Line 7 
7  end  end
8    
9    
10  structure Loopify =  structure Loopify :> LOOPIFY =
11  struct  struct
12  local  local
13      structure F  = FLINT      structure F  = FLINT
     structure C  = Collect  
14      structure O  = Option      structure O  = Option
15      structure M  = IntmapF      structure M  = IntmapF
16        structure S  = IntSetF
17      structure LK = LtyKernel      structure LK = LtyKernel
18  in  in
19    
20  fun bug msg = ErrorMsg.impossible ("Loopify: "^msg)  fun bug msg = ErrorMsg.impossible ("Loopify: "^msg)
21  val cplv = LambdaVar.dupLvar  val cplv = LambdaVar.dupLvar
22    
23    datatype info = I of {tails : int ref, calls: int ref, icalls: int ref, tcp: bool ref, parent: F.lvar}
24    exception NotFound
25    
26  fun loopify (prog as (progkind,progname,progargs,progbody)) = let  fun loopify (prog as (progkind,progname,progargs,progbody)) = let
27    
28        val m : info Intmap.intmap = Intmap.new(128, NotFound)
29    
30        (* tails: number of tail-recursive calls
31         * calls: number of other calls
32         * icalls: non-tail self-recursive subset of `calls'
33         * tcp: always called in tail-position
34         * parent: enclosing function *)
35        fun new (f,known,parent) =
36            let val i = I{tails=ref 0, calls=ref 0, icalls=ref 0,
37                          tcp=ref known, parent=parent}
38            in Intmap.add m (f,i); i end
39    
40        fun get f = Intmap.map m f
41    
42    (* collect tries to determine what calls are tail recursive.
43     * If a function f is always called in tail position in a function g,
44     * then all tail calls to g from f are indeed tail recursive. *)
45    (* tfs:  we are currently in tail position relative to those functions
46     * p:  englobing function *)
47    fun collect p tfs le = let
48        val loop = collect p tfs
49    in case le
50        of F.RET _ => ()
51         | F.LET(_,body,le) => (collect p S.empty body; loop le)
52         | F.FIX([({isrec=(NONE | SOME(_,F.LK_TAIL)),known,...},f,_,body)],le) =>
53           let val I{tcp,calls,icalls,...} = new(f, known, p)
54               val _ = loop le
55               val ecalls = !calls
56           in  collect f (if !tcp then S.add(f,tfs) else S.singleton f) body;
57               icalls := !calls - ecalls
58           end
59         | F.FIX(fdecs,le) =>
60           let (* create the new entries in the map *)
61               val fs = map (fn (fk as {known,...},f,_,body) =>
62                             (fk, f, body, new(f, false, p)))
63                            fdecs
64               fun cfun ({isrec,...}:F.fkind,f,body,I{calls,icalls,...}) =
65                   let val ecalls = !calls
66                   in  collect f (S.singleton f) body;
67                       icalls := !calls - ecalls
68                   end
69           in  loop le;
70               app cfun fs
71           end
72         | F.APP(F.VAR f,vs) =>
73           (let val I{tails,calls,tcp,parent,...} = get f
74           in if S.member tfs f then tails := !tails + 1
75              else (calls := !calls + 1;
76                    if S.member tfs parent then () else tcp := false)
77           end handle NotFound => ())
78         | F.TFN((_,_,body),le) => (collect p S.empty body; loop le)
79         | F.TAPP _ => ()
80         | F.SWITCH(v,ac,arms,def) =>
81           let fun carm (_,body) = loop body
82           in app carm arms; case def of SOME le => loop le | _ => ()
83           end
84         | (F.CON(_,_,_,_,le) | F.RECORD(_,_,_,le) |
85            F.SELECT(_,_,_,le) | F.PRIMOP(_,_,_,le)) => loop le
86         | F.RAISE _ => ()
87         | F.HANDLE(le,v) => collect p S.empty le
88         | F.BRANCH(_,_,le1,le2) => (loop le1; loop le2)
89    
90         | F.APP _ => bug "weird F.APP in collect"
91    end
92    
93  (* m: int intmap        renaming for function calls  (* m: int intmap        renaming for function calls
94   * tf:(int,int) option  the current function (if any) and its tail version   * tf:(int,int) list    the current functions (if any) and their tail version
95   * le:                  you get the idea *)   * le:                  you get the idea *)
96  fun lexp m tf le = let  fun lexp m tfs le = let
97      val loop = lexp m tf      val loop = lexp m tfs
98  in case le  in case le
99      of F.RET _ => le      of F.RET _ => le
100       | F.LET(lvs,body,le) => F.LET(lvs, lexp m NONE body, loop le)       | F.LET(lvs,body,le) => F.LET(lvs, lexp m [] body, loop le)
101       | F.FIX(fdecs,le) =>       | F.FIX(fdecs,le) =>
102         let fun cfun (fk:F.fkind as {isrec=SOME(ltys,F.LK_UNKNOWN),cconv,...},         let fun cfun (fk:F.fkind as {isrec=SOME(ltys,F.LK_UNKNOWN),cconv,...},
103                       f,args,body) =                       f,args,body) =
104                 let val fi = C.get f                 let val I{tcp=ref tcp,icalls=ref icalls,tails=ref tails,...} =
105                     val icallnb = C.icallnb fi                         get f
106                 (* cpsopt uses the following condition:                 (* cpsopt uses the following condition:
107                  *     escape = 0 andalso !unroll_call > 0                  *     escape = 0 andalso !unroll_call > 0
108                  *           andalso (!call - !unroll_call > 1                  *           andalso (!call - !unroll_call > 1
# Line 53  Line 121 
121                  * `C.callnb fi <= icallnb + 1': if there's only one external                  * `C.callnb fi <= icallnb + 1': if there's only one external
122                  *     call, loopification will probably (?) not be of much use                  *     call, loopification will probably (?) not be of much use
123                  *     and the same benefit would be had by just moving f *)                  *     and the same benefit would be had by just moving f *)
124                 in if icallnb = 0 (* orelse (C.callnb fi <= icallnb + 1) *)                 in if icalls = 0 andalso tails = 0
125                    (* not a good loop candidate *)                    then (fk, f, args, lexp m (if tcp then tfs else []) body)
                   then (fk, f, args, loop body)  
126                    else                    else
127                        let val fl = cplv f                        let val fl = cplv f
128                            val ft = cplv f                            val ft = cplv f
# Line 67  Line 134 
134                                  | F.CC_FUN(LK.FF_VAR(f1,f2)) =>                                  | F.CC_FUN(LK.FF_VAR(f1,f2)) =>
135                                    F.CC_FUN(LK.FF_VAR(true,f2))                                    F.CC_FUN(LK.FF_VAR(true,f2))
136                            val nm = M.add(m, f, fl)                            val nm = M.add(m, f, fl)
137                            val tailloop =                            val tfs' = ((f,ft)::(if tcp then tfs else []))
138                                F.FIX([({isrec=SOME(ltys, F.LK_WHILE),  
139                              (* make the new body *)
140                              val (nargs,nbody) = (args, lexp nm tfs' body)
141                              (* wrap into a tail loop if necessary *)
142                              val (nargs,nbody) =
143                                  if tails = 0 then (nargs,nbody) else let
144                                      val args' = map (fn(v,t) => (cplv v, t)) args
145                                  in (args',
146                                      F.FIX([({isrec=SOME(ltys, F.LK_TAIL),
147                                         known=true, inline=F.IH_SAFE,                                         known=true, inline=F.IH_SAFE,
148                                         cconv=cconv'}, ft, args,                                             cconv=cconv'}, ft, nargs,
149                                        lexp nm (SOME(f,ft)) body)],                                            nbody)],
150                                      F.APP(F.VAR ft, map (F.VAR o #1) largs))                                      F.APP(F.VAR ft, map (F.VAR o #1) args')))
151                        in (fk, f, args',                                end
152                              (* wrap into a non-tail loop if necessary *)
153                              val (nargs,nbody) =
154                                  if icalls = 0 then (nargs,nbody) else let
155                                      val args' = map (fn(v,t) => (cplv v, t)) args
156                                  in (args',
157                            F.FIX([({isrec=SOME(ltys, F.LK_LOOP),                            F.FIX([({isrec=SOME(ltys, F.LK_LOOP),
158                                     known=true, inline=F.IH_SAFE,                                     known=true, inline=F.IH_SAFE,
159                                     cconv=cconv'}, fl, largs,                                             cconv=cconv'}, fl, nargs,
160                                    tailloop)],                                            nbody)],
161                                  F.APP(F.VAR fl, map (F.VAR o #1) args')))                                  F.APP(F.VAR fl, map (F.VAR o #1) args')))
162                        end                        end
163                          in (fk, f, nargs, nbody)
164                          end
165                   end
166                 | cfun (fk as {inline=F.IH_UNROLL,isrec=SOME _,...},f,args,body) =
167                   let val I{tcp=ref tcp,...} = get f
168                   in (fk, f, args, lexp m (if tcp then tfs else []) body)
169                   end
170                 | cfun (fk,f,args,body) =
171                   let val I{tcp=ref tcp,...} = get f
172                   in (fk, f, args, lexp m (if tcp then tfs else []) body)
173                 end                 end
              | cfun (fk,f,args,body) = (fk, f, args, lexp m NONE body)  
174         in F.FIX(map cfun fdecs, loop le)         in F.FIX(map cfun fdecs, loop le)
175         end         end
176       | F.APP(F.VAR f,vs) =>       | F.APP(F.VAR f,vs) =>
177         (let val fl = M.lookup m f         (let val fl = M.lookup m f
178         in case tf         in case List.find (fn (ft,ft') => ft = f) tfs
179             of SOME(f',ft) => if f' = f then F.APP(F.VAR ft, vs)             of SOME(ft, ft') => F.APP(F.VAR ft', vs)
                              else F.APP(F.VAR fl, vs)  
180              | NONE => F.APP(F.VAR fl, vs)              | NONE => F.APP(F.VAR fl, vs)
181         end handle M.IntmapF => le)         end handle M.IntmapF => le)
182       | F.TFN((f,args,body),le) => F.TFN((f, args, loop body), loop le)       | F.TFN((f,args,body),le) => F.TFN((f, args, loop body), loop le)
# Line 101  Line 189 
189       | F.RECORD(rk,vs,lv,le) => F.RECORD(rk, vs, lv, loop le)       | F.RECORD(rk,vs,lv,le) => F.RECORD(rk, vs, lv, loop le)
190       | F.SELECT(v,i,lv,le) => F.SELECT(v, i, lv, loop le)       | F.SELECT(v,i,lv,le) => F.SELECT(v, i, lv, loop le)
191       | F.RAISE(v,ltys) => le       | F.RAISE(v,ltys) => le
192       | F.HANDLE(le,v) => F.HANDLE(loop le, v)       | F.HANDLE(le,v) => F.HANDLE(lexp m [] le, v)
193       | F.BRANCH(po,vs,le1,le2) => F.BRANCH(po, vs, loop le1, loop le2)       | F.BRANCH(po,vs,le1,le2) => F.BRANCH(po, vs, loop le1, loop le2)
194       | F.PRIMOP(po,vs,lv,le) => F.PRIMOP(po, vs, lv, loop le)       | F.PRIMOP(po,vs,lv,le) => F.PRIMOP(po, vs, lv, loop le)
195    
# Line 109  Line 197 
197  end  end
198    
199  in  in
200      C.collect prog;                     (* Collect is way overkill here *)      collect progname S.empty progbody;
201      (progkind, progname, progargs, lexp M.empty NONE progbody)      (progkind, progname, progargs, lexp M.empty [] progbody)
202  end  end
203    
204  end  end

Legend:
Removed from v.198  
changed lines
  Added in v.199

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