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 202, Sun Dec 13 02:29:45 1998 UTC revision 203, Sat Dec 19 20:51:39 1998 UTC
# Line 14  Line 14 
14      structure O  = Option      structure O  = Option
15      structure M  = IntmapF      structure M  = IntmapF
16      structure S  = IntSetF      structure S  = IntSetF
17        structure OU = OptUtils
18      structure LK = LtyKernel      structure LK = LtyKernel
19        structure CTRL = Control.FLINT
20  in  in
21    
22    val say = Control.Print.say
23  fun bug msg = ErrorMsg.impossible ("Loopify: "^msg)  fun bug msg = ErrorMsg.impossible ("Loopify: "^msg)
24  val cplv = LambdaVar.dupLvar  val cplv = LambdaVar.dupLvar
25    
26  datatype info = I of {tails : int ref, calls: int ref, icalls: int ref, tcp: bool ref, parent: F.lvar}  type al = F.value list list
27    datatype info = I of {tails : al ref, calls: al ref, icalls: al ref,
28                          tcp: bool ref, parent: F.lvar}
29  exception NotFound  exception NotFound
30    
31  fun loopify (prog as (progkind,progname,progargs,progbody)) = let  fun loopify (prog as (progkind,progname,progargs,progbody)) = let
# Line 33  Line 38 
38       * tcp: always called in tail-position       * tcp: always called in tail-position
39       * parent: enclosing function *)       * parent: enclosing function *)
40      fun new (f,known,parent) =      fun new (f,known,parent) =
41          let val i = I{tails=ref 0, calls=ref 0, icalls=ref 0,          let val i = I{tails=ref [], calls=ref [], icalls=ref [],
42                        tcp=ref known, parent=parent}                        tcp=ref known, parent=parent}
43          in Intmap.add m (f,i); i end          in Intmap.add m (f,i); i end
44    
# Line 52  Line 57 
57       | F.FIX([({isrec=(NONE | SOME(_,F.LK_TAIL)),known,...},f,_,body)],le) =>       | F.FIX([({isrec=(NONE | SOME(_,F.LK_TAIL)),known,...},f,_,body)],le) =>
58         let val I{tcp,calls,icalls,...} = new(f, known, p)         let val I{tcp,calls,icalls,...} = new(f, known, p)
59             val _ = loop le             val _ = loop le
60             val ecalls = !calls             val necalls = length(!calls)
61         in  collect f (if !tcp then S.add(f,tfs) else S.singleton f) body;         in  collect f (if !tcp then S.add(f,tfs) else S.singleton f) body;
62             icalls := !calls - ecalls             icalls := List.take(!calls, length(!calls) - necalls)
63         end         end
64       | F.FIX(fdecs,le) =>       | F.FIX(fdecs,le) =>
65         let (* create the new entries in the map *)         let (* create the new entries in the map *)
# Line 62  Line 67 
67                           (fk, f, body, new(f, false, p)))                           (fk, f, body, new(f, false, p)))
68                          fdecs                          fdecs
69             fun cfun ({isrec,...}:F.fkind,f,body,I{calls,icalls,...}) =             fun cfun ({isrec,...}:F.fkind,f,body,I{calls,icalls,...}) =
70                 let val ecalls = !calls                 let val necalls = length(!calls)
71                 in  collect f (S.singleton f) body;                 in  collect f (S.singleton f) body;
72                     icalls := !calls - ecalls                     icalls := List.take(!calls, length(!calls) - necalls)
73                 end                 end
74         in  loop le;         in  loop le;
75             app cfun fs             app cfun fs
76         end         end
77       | F.APP(F.VAR f,vs) =>       | F.APP(F.VAR f,vs) =>
78         (let val I{tails,calls,tcp,parent,...} = get f         (let val I{tails,calls,tcp,parent,...} = get f
79         in if S.member tfs f then tails := !tails + 1         in if S.member tfs f then tails := vs::(!tails)
80            else (calls := !calls + 1;            else (calls := vs::(!calls);
81                  if S.member tfs parent then () else tcp := false)                  if S.member tfs parent then () else tcp := false)
82         end handle NotFound => ())         end handle NotFound => ())
83       | F.TFN((_,_,body),le) => (collect p S.empty body; loop le)       | F.TFN((_,_,body),le) => (collect p S.empty body; loop le)
# Line 90  Line 95 
95       | F.APP _ => bug "weird F.APP in collect"       | F.APP _ => bug "weird F.APP in collect"
96  end  end
97    
98    (* (intended as a `foldr' argument).
99     * `filt' is the bool list indicating if the arg is kept
100     * `func' is the list of arguments for the FIX
101     * `call' is the list of arguments for the APP
102     * `free' is the list of resulting free variables *)
103    fun drop_invariant ((v,t),actuals,(filt,func,call,free)) =
104        if !CTRL.dropinvariant andalso List.all (fn a => F.VAR v = a) actuals then
105            (* drop the argument: the free list is unchanged *)
106            (false::filt, func, call, (v,t)::free)
107        else
108            (* keep the argument: create a new var (used in the call)
109             * which will replace the old in the free vars *)
110            let val nv = cplv v
111            in (true::filt, (v,t)::func, (F.VAR nv)::call, (nv,t)::free)
112            end
113    
114  (* m: int intmap        renaming for function calls  (* m: int intmap        renaming for function calls
115   * tf:(int,int) list    the current functions (if any) and their tail version   * tf:(int,int) list    the current functions (if any) and their tail version
116   * le:                  you get the idea *)   * le:                  you get the idea *)
# Line 121  Line 142 
142                  * `C.callnb fi <= icallnb + 1': if there's only one external                  * `C.callnb fi <= icallnb + 1': if there's only one external
143                  *     call, loopification will probably (?) not be of much use                  *     call, loopification will probably (?) not be of much use
144                  *     and the same benefit would be had by just moving f *)                  *     and the same benefit would be had by just moving f *)
145                 in if icalls = 0 andalso tails = 0                 in if null icalls andalso null tails
146                    then (fk, f, args, lexp m (if tcp then tfs else []) body)                    then (fk, f, args, lexp m (if tcp then tfs else []) body)
147                    else                    else
148                        let val fl = cplv f                        let val cconv' =
                           val ft = cplv f  
                           val largs = map (fn(v,t) => (cplv v, t)) args  
                           val args' = map (fn(v,t) => (cplv v, t)) args  
                           val cconv' =  
149                                case cconv                                case cconv
150                                 of (F.CC_FCT | F.CC_FUN(LK.FF_FIXED)) => cconv                                 of (F.CC_FCT | F.CC_FUN(LK.FF_FIXED)) => cconv
151                                  | F.CC_FUN(LK.FF_VAR(f1,f2)) =>                                  | F.CC_FUN(LK.FF_VAR(f1,f2)) =>
152                                    F.CC_FUN(LK.FF_VAR(true,f2))                                    F.CC_FUN(LK.FF_VAR(true,f2))
153                            val nm = M.add(m, f, fl)  
154                            val tfs' = ((f,ft)::(if tcp then tfs else []))                            (* figure out what arguments of the tail loop
155                               * are invariants and create the corresponding
156                               * function args, call args, filter
157                               * function for the actual calls, ... *)
158                              val (tfs',atfun,atcall,args,ft) =
159                                  if null tails then (tfs,[],[],args,f) else let
160                                      val ft = cplv f
161                                      val actuals = OU.transpose tails
162                                      val (fcall,afun,acall,afree) =
163                                          ListPair.foldr drop_invariant
164                                                         ([],[],[],[])
165                                                         (args, actuals)
166                                  in ((f,ft,fcall)::(if tcp then tfs else []),
167                                      afun, acall, afree, ft)
168                                  end
169    
170                              (* Do the same for the non-tail loop *)
171                              val (nm,alfun,alcall,args,fl) =
172                                  if null icalls then (m,[],[],args,f) else let
173                                      val fl = cplv f
174                                      val actuals = OU.transpose icalls
175                                      val (fcall,afun,acall,afree) =
176                                          ListPair.foldr drop_invariant
177                                                         ([],[],[],[])
178                                                         (args, actuals)
179                                  in (M.add(m, f, (fl, fcall)),
180                                      afun, acall, afree, fl)
181                                  end
182    
183                            (* make the new body *)                            (* make the new body *)
184                            val (nargs,nbody) = (args, lexp nm tfs' body)                            val nbody = lexp nm tfs' body
185    
186                            (* wrap into a tail loop if necessary *)                            (* wrap into a tail loop if necessary *)
187                            val (nargs,nbody) =                            val nbody =
188                                if tails = 0 then (nargs,nbody) else let                                if null tails then nbody else
                                   val args' = map (fn(v,t) => (cplv v, t)) args  
                               in (args',  
189                                    F.FIX([({isrec=SOME(ltys, F.LK_TAIL),                                    F.FIX([({isrec=SOME(ltys, F.LK_TAIL),
190                                             known=true, inline=F.IH_SAFE,                                             known=true, inline=F.IH_SAFE,
191                                             cconv=cconv'}, ft, nargs,                                             cconv=cconv'}, ft, atfun,
192                                            nbody)],                                            nbody)],
193                                      F.APP(F.VAR ft, map (F.VAR o #1) args')))                                      F.APP(F.VAR ft, atcall))
194                                end  
195                            (* wrap into a non-tail loop if necessary *)                            (* wrap into a non-tail loop if necessary *)
196                            val (nargs,nbody) =                            val nbody =
197                                if icalls = 0 then (nargs,nbody) else let                                if null icalls then nbody else
                                   val args' = map (fn(v,t) => (cplv v, t)) args  
                               in (args',  
198                                    F.FIX([({isrec=SOME(ltys, F.LK_LOOP),                                    F.FIX([({isrec=SOME(ltys, F.LK_LOOP),
199                                             known=true, inline=F.IH_SAFE,                                             known=true, inline=F.IH_SAFE,
200                                             cconv=cconv'}, fl, nargs,                                             cconv=cconv'}, fl, alfun,
201                                            nbody)],                                            nbody)],
202                                      F.APP(F.VAR fl, map (F.VAR o #1) args')))                                      F.APP(F.VAR fl, alcall))
203                                end  
204                        in (fk, f, nargs, nbody)                        in (fk, f, args, nbody)
205                        end                        end
206                 end                 end
207               | cfun (fk as {inline=F.IH_UNROLL,isrec=SOME _,...},f,args,body) =               | cfun (fk as {inline=F.IH_UNROLL,isrec=SOME _,...},f,args,body) =
# Line 174  Line 215 
215         in F.FIX(map cfun fdecs, loop le)         in F.FIX(map cfun fdecs, loop le)
216         end         end
217       | F.APP(F.VAR f,vs) =>       | F.APP(F.VAR f,vs) =>
218         (let val fl = M.lookup m f         (case List.find (fn (ft,ft',filt) => ft = f) tfs
219         in case List.find (fn (ft,ft') => ft = f) tfs           of SOME(ft, ft', filt) => F.APP(F.VAR ft', OU.filter filt vs)
220             of SOME(ft, ft') => F.APP(F.VAR ft', vs)            | NONE => let val (fl,filt) = M.lookup m f
221              | NONE => F.APP(F.VAR fl, vs)              in F.APP(F.VAR fl, OU.filter filt vs)
222         end handle M.IntmapF => le)         end handle M.IntmapF => le)
223       | 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)
224       | F.TAPP(f,tycs) => le       | F.TAPP(f,tycs) => le

Legend:
Removed from v.202  
changed lines
  Added in v.203

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